!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Copyright (C) 2020 Advanced Micro Devices, Inc. All rights Reserved.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine HIP_CHECK(stat)
    use iso_c_binding

    implicit none

    integer(c_int) :: stat

    if(stat /= 0) then
        write(*,*) 'Error: hip error'
        stop
    end if

end subroutine HIP_CHECK

subroutine HIPSPARSE_CHECK(stat)
    use iso_c_binding

    implicit none

    integer(c_int) :: stat

    if(stat /= 0) then
        write(*,*) 'Error: hipsparse error'
        stop
    end if

end subroutine HIPSPARSE_CHECK

program example_fortran_bsrmm
    use iso_c_binding
    use hipsparse

    implicit none

    interface
        function hipMalloc(ptr, size) &
                bind(c, name = 'hipMalloc')
            use iso_c_binding
            implicit none
            integer :: hipMalloc
            type(c_ptr) :: ptr
            integer(c_size_t), value :: size
        end function hipMalloc

        function hipFree(ptr) &
                bind(c, name = 'hipFree')
            use iso_c_binding
            implicit none
            integer :: hipFree
            type(c_ptr), value :: ptr
        end function hipFree

        function hipMemcpy(dst, src, size, kind) &
                bind(c, name = 'hipMemcpy')
            use iso_c_binding
            implicit none
            integer :: hipMemcpy
            type(c_ptr), value :: dst
            type(c_ptr), intent(in), value :: src
            integer(c_size_t), value :: size
            integer(c_int), value :: kind
        end function hipMemcpy

        function hipMemset(dst, val, size) &
                bind(c, name = 'hipMemset')
            use iso_c_binding
            implicit none
            integer :: hipMemset
            type(c_ptr), value :: dst
            integer(c_int), value :: val
            integer(c_size_t), value :: size
        end function hipMemset

        function hipDeviceSynchronize() &
                bind(c, name = 'hipDeviceSynchronize')
            use iso_c_binding
            implicit none
            integer :: hipDeviceSynchronize
        end function hipDeviceSynchronize

        function hipDeviceReset() &
                bind(c, name = 'hipDeviceReset')
            use iso_c_binding
            implicit none
            integer :: hipDeviceReset
        end function hipDeviceReset
    end interface

    integer, target :: h_bsr_row_ptr(3), h_bsr_col_ind(4)
    real(8), target :: h_bsr_val(16), h_B(6 * 10), h_C(4 * 10)

    type(c_ptr) :: d_bsr_row_ptr
    type(c_ptr) :: d_bsr_col_ind
    type(c_ptr) :: d_bsr_val
    type(c_ptr) :: d_B
    type(c_ptr) :: d_C

    integer :: i, j
    integer(c_int) :: M, Mb, N, K, Kb, nnzb, block_dim

    real(c_double), target :: alpha, beta

    type(c_ptr) :: handle
    type(c_ptr) :: descr

    integer :: version

    character(len=12) :: rev

!   Input data
!       ( 1 2 0 3 0 0 )
!   A = ( 0 4 5 0 0 0 )
!       ( 0 0 0 7 8 0 )
!       ( 0 0 1 2 4 1 )

!       ( 9  11 13 15 17 10 12 14 16 18 )
!       ( 8  10 1  10 6  11 7  3  12 17 )
!   B = ( 11 11 0  4  6  12 2  9  13 2  )
!       ( 15 3  2  3  8  1  2  4  6  6  )
!       ( 2  5  7  0  1  15 9  4  10 1  )
!       ( 7  12 12 1  12 5  1  11 1  14 )

!   Number of rows and columns
    block_dim = 2
    Mb = 2
    Kb = 3
    N = 10
    M = Mb * block_dim
    K = Kb * block_dim

!   Number of non-zero blocks
    nnzb = 4

!   Fill BSR structure
    h_bsr_row_ptr = (/0, 2, 4/)
    h_bsr_col_ind = (/0, 1, 1, 2/)
    h_bsr_val     = (/1, 2, 0, 4, 0, 3, 5, 0, 0, 7, 1, 2, 8, 0, 4, 1/)

!   Scalar alpha and beta
    alpha = 1.0
    beta = 0.0

!   Fill B in column-major
    h_B = (/9,  8,  11, 15, 2,  7,  &
            11, 10, 11, 3,  5,  12, &
            13, 1,  0,  2,  7,  12, &
            15, 10, 4,  3,  0,  1,  &
            17, 6,  6,  8,  1,  12, &
            10, 11, 12, 1,  15, 5,  &
            12, 7,  2,  2,  9,  1,  &
            14, 3,  9,  4,  4,  11, &
            16, 12, 13, 6,  10, 1,  &
            18, 17, 2,  6,  1,  14/)

!   Fill C in column-major
    h_C = (/0, 0, 0, 0, &
            0, 0, 0, 0, &
            0, 0, 0, 0, &
            0, 0, 0, 0, &
            0, 0, 0, 0, &
            0, 0, 0, 0, &
            0, 0, 0, 0, &
            0, 0, 0, 0, &
            0, 0, 0, 0, &
            0, 0, 0, 0/)

!   Allocate device memory
    call HIP_CHECK(hipMalloc(d_bsr_row_ptr, (int(Mb, c_size_t) + 1) * 4))
    call HIP_CHECK(hipMalloc(d_bsr_col_ind, int(nnzb, c_size_t) * 4))
    call HIP_CHECK(hipMalloc(d_bsr_val, int(nnzb * block_dim * block_dim, c_size_t) * 8))
    call HIP_CHECK(hipMalloc(d_B, int(K * N, c_size_t) * 8))
    call HIP_CHECK(hipMalloc(d_C, int(M * N, c_size_t) * 8))

!   Copy host data to device
    call HIP_CHECK(hipMemcpy(d_bsr_row_ptr, c_loc(h_bsr_row_ptr), (int(Mb, c_size_t) + 1) * 4, 1))
    call HIP_CHECK(hipMemcpy(d_bsr_col_ind, c_loc(h_bsr_col_ind), int(nnzb, c_size_t) * 4, 1))
    call HIP_CHECK(hipMemcpy(d_bsr_val, c_loc(h_bsr_val), int(nnzb * block_dim * block_dim, c_size_t) * 8, 1))
    call HIP_CHECK(hipMemcpy(d_B, c_loc(h_B), int(K * N, c_size_t) * 8, 1))
    call HIP_CHECK(hipMemcpy(d_C, c_loc(h_C), int(M * N, c_size_t) * 8, 1))

!   Create hipSPARSE handle
    call HIPSPARSE_CHECK(hipsparseCreate(handle))

!   Get hipSPARSE version
    call HIPSPARSE_CHECK(hipsparseGetVersion(handle, version))

!   Print version on screen
    write(*,fmt='(A,I0,A,I0,A,I0)') 'hipSPARSE version: ', version / 100000, '.', &
        mod(version / 100, 1000), '.', mod(version, 100)

!   Create matrix descriptor
    call HIPSPARSE_CHECK(hipsparseCreateMatDescr(descr))

!   Perform the matrix multiplication
    call HIPSPARSE_CHECK(hipsparseDbsrmm(handle, &
                                          HIPSPARSE_DIRECTION_ROW, &
                                          HIPSPARSE_OPERATION_NON_TRANSPOSE, &
                                          HIPSPARSE_OPERATION_NON_TRANSPOSE, &
                                          Mb, &
                                          N, &
                                          Kb, &
                                          nnzb, &
                                          c_loc(alpha), &
                                          descr, &
                                          d_bsr_val, &
                                          d_bsr_row_ptr, &
                                          d_bsr_col_ind, &
                                          block_dim, &
                                          d_B, &
                                          K, &
                                          c_loc(beta), &
                                          d_C, &
                                          M))

!   Print result
    call HIP_CHECK(hipMemcpy(c_loc(h_C), d_C, int(M * N, c_size_t) * 8, 2))

!   Note: C in column major ordering
    do i = 1, M
        do j = 1, N
            write(*,fmt='(A,F6.2)',advance='no') ' ', h_C(M * (j - 1) + i)
        end do
        write(*,*)
    end do

!   Clear hipSPARSE
    call HIPSPARSE_CHECK(hipsparseDestroyMatDescr(descr))
    call HIPSPARSE_CHECK(hipsparseDestroy(handle))

!   Clear device memory
    call HIP_CHECK(hipFree(d_bsr_row_ptr))
    call HIP_CHECK(hipFree(d_bsr_col_ind))
    call HIP_CHECK(hipFree(d_bsr_val))
    call HIP_CHECK(hipFree(d_B))
    call HIP_CHECK(hipFree(d_C))

end program example_fortran_bsrmm
