librsb 1.3.0.2

Functions/Subroutines
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 <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_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

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