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-2022 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 <https://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_char)
! 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_char)
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_char)
! 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_char)
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
main
auto main() -> int
Definition assemble.cpp:38
rsb_mod_example1
subroutine rsb_mod_example1(res)
Definition fortran_rsb_fi.F90:31
rsb_mod_example3
subroutine rsb_mod_example3(res)
Definition fortran_rsb_fi.F90:197
rsb_mod_example2
subroutine rsb_mod_example2(res)
Definition fortran_rsb_fi.F90:127
rsb::rsb_file_mtx_save
ISO C BINDING interface to rsb_file_mtx_save.
Definition rsb.F90:745
rsb::rsb_lib_exit
ISO C BINDING interface to rsb_lib_exit.
Definition rsb.F90:107
rsb::rsb_lib_get_opt
ISO C BINDING interface to rsb_lib_get_opt.
Definition rsb.F90:95
rsb::rsb_lib_init
ISO C BINDING interface to rsb_lib_init.
Definition rsb.F90:49
rsb::rsb_mtx_alloc_from_coo_begin
ISO C BINDING interface to rsb_mtx_alloc_from_coo_begin.
Definition rsb.F90:118
rsb::rsb_mtx_alloc_from_coo_const
ISO C BINDING interface to rsb_mtx_alloc_from_coo_const.
Definition rsb.F90:211
rsb::rsb_mtx_alloc_from_coo_end
ISO C BINDING interface to rsb_mtx_alloc_from_coo_end.
Definition rsb.F90:134
rsb::rsb_mtx_alloc_from_csr_const
ISO C BINDING interface to rsb_mtx_alloc_from_csr_const.
Definition rsb.F90:145
rsb::rsb_mtx_free
ISO C BINDING interface to rsb_mtx_free.
Definition rsb.F90:271
rsb::rsb_mtx_set_vals
ISO C BINDING interface to rsb_mtx_set_vals.
Definition rsb.F90:650
rsb::rsb_perror
ISO C BINDING interface to rsb_perror.
Definition rsb.F90:37
rsb::rsb_spmv
ISO C BINDING interface to rsb_spmv.
Definition rsb.F90:339
rsb::rsb_tune_spmm
ISO C BINDING interface to rsb_tune_spmm.
Definition rsb.F90:682
rsb
Definition rsb.F90:11
rsb::rsb_flag_default_matrix_flags
integer(c_int), parameter rsb_flag_default_matrix_flags
See RSB_FLAG_DEFAULT_MATRIX_FLAGS.
Definition rsb.F90:1027
rsb::rsb_err_no_error
integer(c_int), parameter rsb_err_no_error
See RSB_ERR_NO_ERROR.
Definition rsb.F90:874
rsb::rsb_io_want_librsb_etime
integer(c_int), parameter rsb_io_want_librsb_etime
See RSB_IO_WANT_LIBRSB_ETIME.
Definition rsb.F90:1135
rsb::rsb_flag_noflags
integer(c_int), parameter rsb_flag_noflags
See RSB_FLAG_NOFLAGS.
Definition rsb.F90:932
rsb::rsb_flag_symmetric
integer(c_int), parameter rsb_flag_symmetric
See RSB_FLAG_SYMMETRIC.
Definition rsb.F90:992
rsb::rsb_flag_want_column_major_order
integer(c_int), parameter rsb_flag_want_column_major_order
See RSB_FLAG_WANT_COLUMN_MAJOR_ORDER.
Definition rsb.F90:947
rsb::rsb_transposition_n
integer(c_int), parameter rsb_transposition_n
Definition rsb.F90:1067
rsb::rsb_flag_fortran_indices_interface
integer(c_int), parameter rsb_flag_fortran_indices_interface
See RSB_FLAG_FORTRAN_INDICES_INTERFACE.
Definition rsb.F90:935
rsb::rsb_numerical_type_double
integer(c_signed_char), parameter rsb_numerical_type_double
Definition rsb.F90:1075

## 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 | ) |