fortran_rsb_fi.F90 File Reference

RSB.F90-based usage: rsb_mtx_alloc_from_coo_const(), rsb_tune_spmm(), rsb_file_mtx_save(), rsb_spmv(), ... More...

Functions/Subroutines
subroutine	rsb_mod_example1 (res)
subroutine	rsb_mod_example2 (res)
subroutine	rsb_mod_example3 (res)
program	main

Detailed Description

RSB.F90-based usage: rsb_mtx_alloc_from_coo_const(), rsb_tune_spmm(), rsb_file_mtx_save(), rsb_spmv(), ...

! 
! Copyright (C) 2008-2019 Michele Martone
! 
! This file is part of librsb.
! 
! librsb is free software; you can redistribute it and/or modify it
! under the terms of the GNU Lesser General Public License as published
! by the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
! 
! librsb is distributed in the hope that it will be useful, but WITHOUT
! ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
! FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
! License for more details.
! 
! You should have received a copy of the GNU Lesser General Public
! License along with librsb; see the file COPYING.
! If not, see <http://www.gnu.org/licenses/>.
! 

!> @file.
!! @brief RSB.F90-based usage:
!!        rsb_mtx_alloc_from_coo_const(),
!!        rsb_tune_spmm(),
!!        rsb_file_mtx_save(),
!!        rsb_spmv(),
!!        ...
!! \include fortran_rsb_fi.F90

      SUBROUTINE rsb_mod_example1(res)
! Example using an unsymmetric matrix specified as COO, and autotuning, built at once.
      USE rsb
      USE iso_c_binding
      IMPLICIT NONE
      INTEGER ::res
      INTEGER,TARGET :: istat = 0, i
      INTEGER :: transt = rsb_transposition_n !
      INTEGER(KIND=RSB_IDX_KIND) :: incx = 1, incy = 1
      REAL(KIND=8),TARGET :: alpha = 3, beta = 1
! 1 1
! 1 1
      ! declaration of VA,IA,JA 
      INTEGER(KIND=RSB_IDX_KIND) :: nnz = 4
      INTEGER(KIND=RSB_IDX_KIND) :: nr = 2
      INTEGER(KIND=RSB_IDX_KIND) :: nc = 2
      INTEGER(KIND=RSB_IDX_KIND) :: nrhs = 1
      INTEGER :: order = rsb_flag_want_column_major_order ! rhs layout
      INTEGER :: flags = rsb_flag_noflags 
      INTEGER(KIND=RSB_IDX_KIND),TARGET :: ia(4) = (/0, 1, 1,0/)
      INTEGER(KIND=RSB_IDX_KIND),TARGET :: ja(4) = (/0, 0, 1,1/)
      REAL(KIND=8),TARGET :: va(4) = (/1,1,1,1/)
      REAL(KIND=8),TARGET :: x(2) = (/1, 1/)! reference x 
      REAL(KIND=8),TARGET :: cy(2) = (/9, 9/)! reference cy after 
      REAL(KIND=8),TARGET :: y(2) = (/3, 3/)! y will be overwritten
      TYPE(c_ptr),TARGET :: mtxap = c_null_ptr ! matrix pointer
      REAL(KIND=8) :: tmax = 2.0 ! tuning max time
      INTEGER :: titmax = 2 ! tuning max iterations
      INTEGER,TARGET :: ont = 0     ! optimal number of threads
      !TYPE(C_PTR),PARAMETER :: EO = RSB_NULL_EXIT_OPTIONS
      !TYPE(C_PTR),PARAMETER :: IO = RSB_NULL_INIT_OPTIONS
      ! Note: using C_NULL_PTR instead of the previous lines because of http://gcc.gnu.org/bugzilla/show_bug.cgi?id=59411
      TYPE(c_ptr),PARAMETER :: eo = c_null_ptr
      TYPE(c_ptr),PARAMETER :: io = c_null_ptr
      INTEGER,TARGET :: errval

      res = 0

      errval = rsb_lib_init(io)
      IF (errval.NE.rsb_err_no_error) GOTO 9997

      mtxap = rsb_mtx_alloc_from_coo_const(c_loc(va),c_loc(ia),c_loc(ja)&
       &,nnz,&
       & rsb_numerical_type_double,nr,nc,1,1,flags,c_loc(istat))

      IF (istat.NE.rsb_err_no_error) GOTO 9997

      istat = rsb_file_mtx_save(mtxap,c_null_ptr)

      ! Structure autotuning:
      istat = rsb_tune_spmm(c_loc(mtxap),c_null_ptr,c_null_ptr,titmax,&
       & tmax,&
       & transt,c_loc(alpha),c_null_ptr,nrhs,order,c_loc(x),nr,&
       & c_loc(beta),c_loc(y),nc)

      IF (istat.NE.rsb_err_no_error) GOTO 9997

      ! Thread count autotuning:
      istat = rsb_tune_spmm(c_null_ptr,c_null_ptr,c_loc(ont),titmax,&
       & tmax,&
       & transt,c_loc(alpha),mtxap,nrhs,order,c_loc(x),nr,c_loc(beta),&
       & c_loc(y),nc)
      print *, "Optimal number of threads:", ont

      y(:) = (/3, 3/)! restoring reference y (rsb_tune_spmm has overwritten it)
      IF (istat.NE.rsb_err_no_error) GOTO 9997
      
      istat = rsb_file_mtx_save(mtxap,c_null_ptr)
      IF (istat.NE.rsb_err_no_error) GOTO 9997

      istat = rsb_spmv(transt,c_loc(alpha),mtxap,c_loc(x),incx,&
       & c_loc(beta),c_loc(y),incy)
      IF (istat.NE.rsb_err_no_error) GOTO 9997
      DO i = 1, 2
            IF (y(i).NE.cy(i)) print *, "type=d dims=2x2 sym=g diag=g &
      &blocks=1x1 usmv alpha= 3 beta= 1 incx=1 incy=1 trans=n is not ok"
            IF (y(i).NE.cy(i)) GOTO 9997
      END DO
      print*,"type=d dims=2x2 sym=g diag=g blocks=1x1 usmv alpha= 3&
       & beta= 1 incx=1 incy=1 trans=n is ok"

      IF ( res .NE.rsb_err_no_error) GOTO 9997
      GOTO 9998
9997      res = -1
9998      CONTINUE
      mtxap = rsb_mtx_free(mtxap)
      IF (istat.NE.rsb_err_no_error) res = -1 
! 9999      CONTINUE
      errval=rsb_lib_exit(eo)                 ! librsb finalization
      IF (errval.NE.rsb_err_no_error)&
       & stop "error calling rsb_lib_exit"
      print *, "rsb module fortran test is ok"

      istat = rsb_perror(c_null_ptr,istat)
      end SUBROUTINE rsb_mod_example1

      SUBROUTINE rsb_mod_example2(res)
! Example using an unsymmetric matrix specified as COO, and autotuning, built piecewise.
      USE rsb
      USE iso_c_binding
      IMPLICIT NONE
      INTEGER,TARGET :: errval
      INTEGER :: res
      INTEGER :: transt = rsb_transposition_n  ! no transposition
      INTEGER(KIND=RSB_IDX_KIND) :: incx = 1, incb = 1        ! X, B vectors increment
      REAL(KIND=8),TARGET :: alpha = 3,beta = 1
      INTEGER(KIND=RSB_IDX_KIND) :: nnza = 4, nra = 3, nca = 3     ! nonzeroes, rows, columns of matrix A
      INTEGER(KIND=RSB_IDX_KIND),TARGET :: ia(4) = (/1, 2, 3, 3/)  ! row    indices
      INTEGER(KIND=RSB_IDX_KIND),TARGET :: ja(4) = (/1, 2, 1, 3/)  ! column indices
      INTEGER(C_SIGNED_CHAR) :: typecode = rsb_numerical_type_double
      INTEGER :: flags =rsb_flag_default_matrix_flags+rsb_flag_symmetric
      REAL(KIND=8),TARGET :: va(4) = (/11.0, 22.0, 13.0, 33.0/) ! coefficients
      REAL(KIND=8),TARGET :: x(3) = (/   0,    0,    0/)
      REAL(KIND=8),TARGET :: b(3) = (/-1.0, -2.0, -2.0/)
      TYPE(c_ptr),TARGET  :: mtxap = c_null_ptr
      TYPE(c_ptr)  :: mtxapp = c_null_ptr
      REAL(KIND=8),TARGET :: etime = 0.0
      !TYPE(C_PTR),PARAMETER :: EO = RSB_NULL_EXIT_OPTIONS
      !TYPE(C_PTR),PARAMETER :: IO = RSB_NULL_INIT_OPTIONS
      ! Note: using C_NULL_PTR instead of the previous lines because of http://gcc.gnu.org/bugzilla/show_bug.cgi?id=59411
      TYPE(c_ptr),PARAMETER :: eo = c_null_ptr
      TYPE(c_ptr),PARAMETER :: io = c_null_ptr

      errval = rsb_lib_init(io)                ! librsb initialization
      IF (errval.NE.rsb_err_no_error) &
       & stop "error calling rsb_lib_init"
#if defined(__GNUC__) && (__GNUC__ == 4) && (__GNUC_MINOR__ < 5)
#define RSB_SKIP_BECAUSE_OLD_COMPILER 1
#endif
#ifndef RSB_SKIP_BECAUSE_OLD_COMPILER
      mtxap = rsb_mtx_alloc_from_coo_begin(nnza,typecode,nra,nca,flags,&
       & c_loc(errval)) ! begin matrix creation
      errval = rsb_mtx_set_vals(mtxap,&
       & c_loc(va),c_loc(ia),c_loc(ja),nnza,flags) ! insert some nonzeroes
      mtxapp = c_loc(mtxap) ! Old compilers like e.g.: Gfortran 4.4.7 will NOT compile this.
      IF (errval.NE.rsb_err_no_error) &
       & stop "error calling rsb_mtx_set_vals"
      errval = rsb_mtx_alloc_from_coo_end(mtxapp)                   ! end matrix creation
      IF (errval.NE.rsb_err_no_error) &
       & stop "error calling rsb_mtx_alloc_from_coo_end"
      errval = rsb_spmv(transt,c_loc(alpha),mtxap,c_loc(x),&
       & incx,c_loc(beta),c_loc(b),incb) ! X := X + (3) * A * B 
      IF (errval.NE.rsb_err_no_error)&
       & stop "error calling rsb_spmv"
      mtxap = rsb_mtx_free(mtxap)                                 ! destroy matrix

      ! The following is optional and depends on configure options, so it is allowed to fail
      errval = rsb_lib_get_opt(rsb_io_want_librsb_etime,c_loc(etime))
      IF (errval.EQ.rsb_err_no_error)&
       & print*,"Time spent in librsb is:",etime
      ! IF (errval.NE.0)STOP "error calling rsb_lib_get_opt" 
      errval = rsb_err_no_error

      IF (errval.NE.rsb_err_no_error) &
       & stop "error calling rsb_mtx_free"
#else
      print*,"You have an old Fortran compiler not supporting C_LOC."
      print*,"Skipping a part of the test"
#endif
      errval=rsb_lib_exit(eo)                 ! librsb finalization
      IF (errval.NE.rsb_err_no_error)&
       & stop "error calling rsb_lib_exit"
      print *, "rsb module fortran test is ok"
      res = errval
      end SUBROUTINE rsb_mod_example2

      SUBROUTINE rsb_mod_example3(res)
! Example using a symmetric matrix specified as CSR, and autotuning, built at once.
      USE rsb
      USE iso_c_binding
      IMPLICIT NONE
      INTEGER ::res
      INTEGER,TARGET :: istat = 0, i
      INTEGER :: transt = rsb_transposition_n !
      INTEGER(KIND=RSB_IDX_KIND) :: incx = 1, incy = 1
      REAL(KIND=8),TARGET :: alpha = 4, beta = 1
! 11 21 
! 21 22 
      ! declaration of VA,IP,JA 
      INTEGER(KIND=RSB_IDX_KIND), PARAMETER :: nnz = 3
      INTEGER(KIND=RSB_IDX_KIND), PARAMETER :: nr = 2
      INTEGER(KIND=RSB_IDX_KIND), PARAMETER :: nc = 2
      INTEGER(KIND=RSB_IDX_KIND), PARAMETER :: nrhs = 1
      INTEGER :: order = rsb_flag_want_column_major_order ! rhs layout
      INTEGER :: flags = rsb_flag_noflags + rsb_flag_symmetric + &
       &                 rsb_flag_fortran_indices_interface        !  optional flags
      INTEGER(KIND=RSB_IDX_KIND),TARGET :: ip(3) = (/1, 2, 4/)
      INTEGER(KIND=RSB_IDX_KIND),TARGET :: ja(3) = (/1, 1, 2/)
      REAL(KIND=8),TARGET :: va(3) = (/11,21,22/) ! lower triangle coefficients
      REAL(KIND=8),TARGET :: x(2) = (/1, 2/)! reference x 
      REAL(KIND=8),TARGET :: cy(2) = (/215.0, 264.0/)! reference cy after 
      REAL(KIND=8),TARGET :: y(2) = (/3, 4/)! y will be overwritten
      TYPE(c_ptr),TARGET :: mtxap = c_null_ptr ! matrix pointer
      REAL(KIND=8) :: tmax = 2.0 ! tuning max time
      INTEGER :: titmax = 2 ! tuning max iterations
      INTEGER,TARGET :: ont = 0     ! optimal number of threads
      TYPE(c_ptr),PARAMETER :: eo = c_null_ptr
      TYPE(c_ptr),PARAMETER :: io = c_null_ptr
      INTEGER,TARGET :: errval

      errval = rsb_lib_init(io)                ! librsb initialization
      IF (errval.NE.rsb_err_no_error) &
       & stop "error calling rsb_lib_init"

      res = 0
      mtxap = rsb_mtx_alloc_from_csr_const(c_loc(va),c_loc(ip),c_loc(ja)&
       &,nnz,rsb_numerical_type_double,nr,nc,1,1,flags,c_loc(istat))

      IF (istat.NE.rsb_err_no_error) GOTO 9997

      istat = rsb_file_mtx_save(mtxap,c_null_ptr)

      ! Structure autotuning:
      istat = rsb_tune_spmm(c_loc(mtxap),c_null_ptr,c_null_ptr,titmax,&
       & tmax,&
       & transt,c_loc(alpha),c_null_ptr,nrhs,order,c_loc(x),nr,&
       & c_loc(beta),c_loc(y),nc)

      IF (istat.NE.rsb_err_no_error) GOTO 9997

      ! Thread count autotuning:
      istat = rsb_tune_spmm(c_null_ptr,c_null_ptr,c_loc(ont),titmax,&
       & tmax,&
       & transt,c_loc(alpha),mtxap,nrhs,order,c_loc(x),nr,c_loc(beta),&
       & c_loc(y),nc)
      print *, "Optimal number of threads:", ont

      y(:) = (/3, 4/)! restoring reference y (rsb_tune_spmm has overwritten it)
      IF (istat.NE.rsb_err_no_error) GOTO 9997
      
      istat = rsb_file_mtx_save(mtxap,c_null_ptr)
      IF (istat.NE.rsb_err_no_error) GOTO 9997

      istat = rsb_spmv(transt,c_loc(alpha),mtxap,c_loc(x),incx,&
       & c_loc(beta),c_loc(y),incy)
      print *, y
      IF (istat.NE.rsb_err_no_error) GOTO 9997
      DO i = 1, 2
            IF (y(i).NE.cy(i)) print *, "type=d dims=2x2 sym=s diag=g &
      &blocks=1x1 usmv alpha= 4 beta= 1 incx=1 incy=1 trans=n is not ok"
            IF (y(i).NE.cy(i)) GOTO 9997
      END DO
      print*,"type=d dims=2x2 sym=s diag=g blocks=1x1 usmv alpha= 4&
       & beta= 1 incx=1 incy=1 trans=n is ok"
      GOTO 9998

      errval=rsb_lib_exit(eo)                 ! librsb finalization
      IF (errval.NE.rsb_err_no_error)&
       & stop "error calling rsb_lib_exit"
      print *, "rsb module fortran test is ok"
9997      res = -1
9998      CONTINUE
      mtxap = rsb_mtx_free(mtxap)
      IF (istat.NE.rsb_err_no_error) res = -1 
! 9999      CONTINUE
      istat = rsb_perror(c_null_ptr,istat)
      end SUBROUTINE rsb_mod_example3

      PROGRAM main
      USE rsb
      IMPLICIT NONE
      INTEGER :: res = rsb_err_no_error, passed = 0, failed = 0

      CALL rsb_mod_example1(res)
      IF (res.LT.0) failed = failed + 1
      IF (res.EQ.0) passed = passed + 1

      CALL rsb_mod_example2(res)
      IF (res.LT.0) failed = failed + 1
      IF (res.EQ.0) passed = passed + 1

      CALL rsb_mod_example3(res)
      IF (res.LT.0) failed = failed + 1
      IF (res.EQ.0) passed = passed + 1
      
      print *, "FAILED:", failed
      print *, "PASSED:", passed
      IF (failed.GT.0) THEN
       stop 1
      END IF
      END PROGRAM

Function/Subroutine Documentation

main()

program main

(

void

)

rsb_mod_example1()

subroutine rsb_mod_example1

(

integer

res

)

rsb_mod_example2()

subroutine rsb_mod_example2

(

integer

res

)

rsb_mod_example3()

subroutine rsb_mod_example3

(

integer

res

)