C ALGORITHM 818, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 28,NO. 2, June, 2002, P. 268--283. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # INSTALL # README.1st # SOFTWARE/ # SOFTWARE/Entry.f90 # SOFTWARE/INSERTING.f90 # SOFTWARE/INS_ROUTINER.f90 # SOFTWARE/Makefile # SOFTWARE/SparseBLAS.f90 # SOFTWARE/SparseBLAS1.f90 # SOFTWARE/blas_sparse.f90 # SOFTWARE/blas_sparse_namedconstants.f90 # SOFTWARE/blas_sparse_proto.f90 # SOFTWARE/conv_tools.f90 # SOFTWARE/dense.f90 # SOFTWARE/hash.f90 # SOFTWARE/info.f90 # SOFTWARE/link.f90 # SOFTWARE/lmbv_bco.f90 # SOFTWARE/lmbv_bdi.f90 # SOFTWARE/lmbv_bsc.f90 # SOFTWARE/lmbv_bsr.f90 # SOFTWARE/lmbv_coo.f90 # SOFTWARE/lmbv_csc.f90 # SOFTWARE/lmbv_csr.f90 # SOFTWARE/lmbv_dia.f90 # SOFTWARE/lmbv_vbr.f90 # SOFTWARE/lsbv_bco.f90 # SOFTWARE/lsbv_bdi.f90 # SOFTWARE/lsbv_bsc.f90 # SOFTWARE/lsbv_bsr.f90 # SOFTWARE/lsbv_coo.f90 # SOFTWARE/lsbv_csc.f90 # SOFTWARE/lsbv_csr.f90 # SOFTWARE/lsbv_dia.f90 # SOFTWARE/lsbv_vbr.f90 # SOFTWARE/mbv.f90 # SOFTWARE/properties.f90 # SOFTWARE/rmbv_bco.f90 # SOFTWARE/rmbv_bdi.f90 # SOFTWARE/rmbv_bsc.f90 # SOFTWARE/rmbv_bsr.f90 # SOFTWARE/rmbv_coo.f90 # SOFTWARE/rmbv_csc.f90 # SOFTWARE/rmbv_csr.f90 # SOFTWARE/rmbv_dia.f90 # SOFTWARE/rmbv_vbr.f90 # SOFTWARE/rsbv_bco.f90 # SOFTWARE/rsbv_bdi.f90 # SOFTWARE/rsbv_bsc.f90 # SOFTWARE/rsbv_bsr.f90 # SOFTWARE/rsbv_coo.f90 # SOFTWARE/rsbv_csc.f90 # SOFTWARE/rsbv_csr.f90 # SOFTWARE/rsbv_dia.f90 # SOFTWARE/rsbv_vbr.f90 # SOFTWARE/sbv.f90 # SOFTWARE/test.f90 # SOFTWARE/types.f90 # SOFTWARE/usaxpy.f90 # SOFTWARE/usconv_bco2bdi.f90 # SOFTWARE/usconv_bco2bsc.f90 # SOFTWARE/usconv_bco2bsr.f90 # SOFTWARE/usconv_bdi2bco.f90 # SOFTWARE/usconv_bsc2bco.f90 # SOFTWARE/usconv_bsr2bco.f90 # SOFTWARE/usconv_coo2csc.f90 # SOFTWARE/usconv_coo2csr.f90 # SOFTWARE/usconv_coo2dia.f90 # SOFTWARE/usconv_csc2coo.f90 # SOFTWARE/usconv_csr2coo.f90 # SOFTWARE/usconv_dia2coo.f90 # SOFTWARE/uscr.f90 # SOFTWARE/uscr_bco.f90 # SOFTWARE/uscr_bdi.f90 # SOFTWARE/uscr_begin.f90 # SOFTWARE/uscr_block_begin.f90 # SOFTWARE/uscr_bsc.f90 # SOFTWARE/uscr_bsr.f90 # SOFTWARE/uscr_coo.f90 # SOFTWARE/uscr_csc.f90 # SOFTWARE/uscr_csr.f90 # SOFTWARE/uscr_dia.f90 # SOFTWARE/uscr_end.f90 # SOFTWARE/uscr_insert_block.f90 # SOFTWARE/uscr_insert_clique.f90 # SOFTWARE/uscr_insert_col.f90 # SOFTWARE/uscr_insert_entries.f90 # SOFTWARE/uscr_insert_entry.f90 # SOFTWARE/uscr_insert_row.f90 # SOFTWARE/uscr_variable_block_begin.f90 # SOFTWARE/uscr_vbr.f90 # SOFTWARE/usdot.f90 # SOFTWARE/usds.f90 # SOFTWARE/usga.f90 # SOFTWARE/usgp.f90 # SOFTWARE/usgz.f90 # SOFTWARE/usmm.f90 # SOFTWARE/usmv.f90 # SOFTWARE/ussc.f90 # SOFTWARE/ussm.f90 # SOFTWARE/ussp.f90 # SOFTWARE/ussv.f90 # SOURCE_FILES/ # SOURCE_FILES/INSERTING_source.F # SOURCE_FILES/INS_ROUTINER_source.F # SOURCE_FILES/conv_tools_source.F # SOURCE_FILES/dense_source.F # SOURCE_FILES/info_source.F # SOURCE_FILES/link_source.F # SOURCE_FILES/lmbv_bco_source.F # SOURCE_FILES/lmbv_bdi_source.F # SOURCE_FILES/lmbv_bsc_source.F # SOURCE_FILES/lmbv_bsr_source.F # SOURCE_FILES/lmbv_coo_source.F # SOURCE_FILES/lmbv_csc_source.F # SOURCE_FILES/lmbv_csr_source.F # SOURCE_FILES/lmbv_dia_source.F # SOURCE_FILES/lmbv_vbr_source.F # SOURCE_FILES/lsbv_bco_source.F # SOURCE_FILES/lsbv_bdi_source.F # SOURCE_FILES/lsbv_bsc_source.F # SOURCE_FILES/lsbv_bsr_source.F # SOURCE_FILES/lsbv_coo_source.F # SOURCE_FILES/lsbv_csc_source.F # SOURCE_FILES/lsbv_csr_source.F # SOURCE_FILES/lsbv_dia_source.F # SOURCE_FILES/lsbv_vbr_source.F # SOURCE_FILES/rmbv_bco_source.F # SOURCE_FILES/rmbv_bdi_source.F # SOURCE_FILES/rmbv_bsc_source.F # SOURCE_FILES/rmbv_bsr_source.F # SOURCE_FILES/rmbv_coo_source.F # SOURCE_FILES/rmbv_csc_source.F # SOURCE_FILES/rmbv_csr_source.F # SOURCE_FILES/rmbv_dia_source.F # SOURCE_FILES/rmbv_vbr_source.F # SOURCE_FILES/rsbv_bco_source.F # SOURCE_FILES/rsbv_bdi_source.F # SOURCE_FILES/rsbv_bsc_source.F # SOURCE_FILES/rsbv_bsr_source.F # SOURCE_FILES/rsbv_coo_source.F # SOURCE_FILES/rsbv_csc_source.F # SOURCE_FILES/rsbv_csr_source.F # SOURCE_FILES/rsbv_dia_source.F # SOURCE_FILES/rsbv_vbr_source.F # SOURCE_FILES/usaxpy_source.F # SOURCE_FILES/usconv_bco2bdi_source.F # SOURCE_FILES/usconv_bco2bsc_source.F # SOURCE_FILES/usconv_bco2bsr_source.F # SOURCE_FILES/usconv_bdi2bco_source.F # SOURCE_FILES/usconv_bsc2bco_source.F # SOURCE_FILES/usconv_bsr2bco_source.F # SOURCE_FILES/usconv_coo2csc_source.F # SOURCE_FILES/usconv_coo2csr_source.F # SOURCE_FILES/usconv_coo2dia_source.F # SOURCE_FILES/usconv_csc2coo_source.F # SOURCE_FILES/usconv_csr2coo_source.F # SOURCE_FILES/usconv_dia2coo_source.F # SOURCE_FILES/uscr_bco_source.F # SOURCE_FILES/uscr_bdi_source.F # SOURCE_FILES/uscr_begin_source.F # SOURCE_FILES/uscr_block_begin_source.F # SOURCE_FILES/uscr_bsc_source.F # SOURCE_FILES/uscr_bsr_source.F # SOURCE_FILES/uscr_coo_source.F # SOURCE_FILES/uscr_csc_source.F # SOURCE_FILES/uscr_csr_source.F # SOURCE_FILES/uscr_dia_source.F # SOURCE_FILES/uscr_end_source.F # SOURCE_FILES/uscr_insert_block_source.F # SOURCE_FILES/uscr_insert_clique_source.F # SOURCE_FILES/uscr_insert_col_source.F # SOURCE_FILES/uscr_insert_entries_source.F # SOURCE_FILES/uscr_insert_entry_source.F # SOURCE_FILES/uscr_insert_row_source.F # SOURCE_FILES/uscr_variable_block_begin_source.F # SOURCE_FILES/uscr_vbr_source.F # SOURCE_FILES/usdot_source.F # SOURCE_FILES/usds_source.F # SOURCE_FILES/usga_source.F # SOURCE_FILES/usgp_source.F # SOURCE_FILES/usgz_source.F # SOURCE_FILES/usmm_source.F # SOURCE_FILES/usmv_source.F # SOURCE_FILES/ussc_source.F # SOURCE_FILES/ussm_source.F # SOURCE_FILES/ussp_source.F # SOURCE_FILES/ussv_source.F # SPEC_ARITH/ # SPEC_ARITH/doubleComplex # SPEC_ARITH/doublePrecision # SPEC_ARITH/integer # SPEC_ARITH/singleComplex # SPEC_ARITH/singlePrecision # TARGET_FILES/ # TARGET_FILES/INSERTING_target.F # TARGET_FILES/INS_ROUTINER_target.F # TARGET_FILES/conv_tools_target.F # TARGET_FILES/dense_target.F # TARGET_FILES/info_target.F # TARGET_FILES/link_target.F # TARGET_FILES/lmbv_bco_target.F # TARGET_FILES/lmbv_bdi_target.F # TARGET_FILES/lmbv_bsc_target.F # TARGET_FILES/lmbv_bsr_target.F # TARGET_FILES/lmbv_coo_target.F # TARGET_FILES/lmbv_csc_target.F # TARGET_FILES/lmbv_csr_target.F # TARGET_FILES/lmbv_dia_target.F # TARGET_FILES/lmbv_vbr_target.F # TARGET_FILES/lsbv_bco_target.F # TARGET_FILES/lsbv_bdi_target.F # TARGET_FILES/lsbv_bsc_target.F # TARGET_FILES/lsbv_bsr_target.F # TARGET_FILES/lsbv_coo_target.F # TARGET_FILES/lsbv_csc_target.F # TARGET_FILES/lsbv_csr_target.F # TARGET_FILES/lsbv_dia_target.F # TARGET_FILES/lsbv_vbr_target.F # TARGET_FILES/rmbv_bco_target.F # TARGET_FILES/rmbv_bdi_target.F # TARGET_FILES/rmbv_bsc_target.F # TARGET_FILES/rmbv_bsr_target.F # TARGET_FILES/rmbv_coo_target.F # TARGET_FILES/rmbv_csc_target.F # TARGET_FILES/rmbv_csr_target.F # TARGET_FILES/rmbv_dia_target.F # TARGET_FILES/rmbv_vbr_target.F # TARGET_FILES/rsbv_bco_target.F # TARGET_FILES/rsbv_bdi_target.F # TARGET_FILES/rsbv_bsc_target.F # TARGET_FILES/rsbv_bsr_target.F # TARGET_FILES/rsbv_coo_target.F # TARGET_FILES/rsbv_csc_target.F # TARGET_FILES/rsbv_csr_target.F # TARGET_FILES/rsbv_dia_target.F # TARGET_FILES/rsbv_vbr_target.F # TARGET_FILES/usaxpy_target.F # TARGET_FILES/usconv_bco2bdi_target.F # TARGET_FILES/usconv_bco2bsc_target.F # TARGET_FILES/usconv_bco2bsr_target.F # TARGET_FILES/usconv_bdi2bco_target.F # TARGET_FILES/usconv_bsc2bco_target.F # TARGET_FILES/usconv_bsr2bco_target.F # TARGET_FILES/usconv_coo2csc_target.F # TARGET_FILES/usconv_coo2csr_target.F # TARGET_FILES/usconv_coo2dia_target.F # TARGET_FILES/usconv_csc2coo_target.F # TARGET_FILES/usconv_csr2coo_target.F # TARGET_FILES/usconv_dia2coo_target.F # TARGET_FILES/uscr_bco_target.F # TARGET_FILES/uscr_bdi_target.F # TARGET_FILES/uscr_begin_target.F # TARGET_FILES/uscr_block_begin_target.F # TARGET_FILES/uscr_bsc_target.F # TARGET_FILES/uscr_bsr_target.F # TARGET_FILES/uscr_coo_target.F # TARGET_FILES/uscr_csc_target.F # TARGET_FILES/uscr_csr_target.F # TARGET_FILES/uscr_dia_target.F # TARGET_FILES/uscr_end_target.F # TARGET_FILES/uscr_insert_block_target.F # TARGET_FILES/uscr_insert_clique_target.F # TARGET_FILES/uscr_insert_col_target.F # TARGET_FILES/uscr_insert_entries_target.F # TARGET_FILES/uscr_insert_entry_target.F # TARGET_FILES/uscr_insert_row_target.F # TARGET_FILES/uscr_variable_block_begin_target.F # TARGET_FILES/uscr_vbr_target.F # TARGET_FILES/usdot_target.F # TARGET_FILES/usds_target.F # TARGET_FILES/usga_target.F # TARGET_FILES/usgp_target.F # TARGET_FILES/usgz_target.F # TARGET_FILES/usmm_target.F # TARGET_FILES/usmv_target.F # TARGET_FILES/ussc_target.F # TARGET_FILES/ussm_target.F # TARGET_FILES/ussp_target.F # TARGET_FILES/ussv_target.F # TESTER/ # TESTER/Makefile.AIX # TESTER/Makefile.ALPHA # TESTER/Makefile.CRAY # TESTER/Makefile.HP # TESTER/Makefile.NAG # TESTER/Makefile.SGI # TESTER/Makefile.SUN # TESTER/main_all.f90 # TESTER/power.f90 # TESTER/test_parameters.f90 # This archive created: Wed Oct 16 11:15:04 2002 export PATH; PATH=/bin:$PATH if test -f 'INSTALL' then echo shar: will not over-write existing file "'INSTALL'" else cat << "SHAR_EOF" > 'INSTALL' #!/bin/sh ###################################################### # -> UNCOMMENT THE APPROPRIATE OF THE FOLLOWING LINES # #SB_ARCH='AIX' #XL Fortran for IBM AIX #SB_ARCH='ALPHA' #DIGITAL Fortran 90 compiler #SB_ARCH='CRAY' #CF90 Fortran compiler #SB_ARCH='HP' #HP Fortran 90 compiler #SB_ARCH='NAG' #NAGWare Fortran 95 compiler #SB_ARCH='SGI' #MIPSpro 7 Fortran 90 compiler SB_ARCH='SUN' #Sun Performance WorkShop Fortran # # -> NOTHING SHOULD BE MODIFIED BELOW HERE ###################################################### if [ ! "$SB_ARCH" ] then echo echo "Before the file INSTALL can be executed, it has to be edited slightly." echo "Open the file in a text editor and set the variable SB_ARCH correctly" echo "by uncommenting the appropriate line." echo exit fi # DIR_ARITH='SPEC_ARITH' DIR_SOFT='SOURCE_FILES' DIR_TARGET='TARGET_FILES' DIR_NMODIF='NMODIF' DIR_CODE='SOFTWARE' DIR_WORK='tmp_workdir' DIR_TEST='TESTER' # echo Creating files... if [ ! -d $DIR_WORK ] then mkdir $DIR_WORK fi ############################################################################## ############################################################################## for file in 'dense' 'info' 'link' 'lmbv_coo' 'lmbv_csc' 'lmbv_csr' 'lmbv_dia' 'lmbv_bco' 'lmbv_bsc' 'lmbv_bsr' 'lmbv_bdi' 'lmbv_vbr' 'lsbv_coo' 'lsbv_csc' 'lsbv_csr' 'lsbv_dia' 'lsbv_bco' 'lsbv_bsc' 'lsbv_bsr' 'lsbv_bdi' 'lsbv_vbr' 'rmbv_coo' 'rmbv_csc' 'rmbv_csr' 'rmbv_dia' 'rmbv_bco' 'rmbv_bsc' 'rmbv_bsr' 'rmbv_bdi' 'rmbv_vbr' 'rsbv_coo' 'rsbv_csc' 'rsbv_csr' 'rsbv_dia' 'rsbv_bco' 'rsbv_bsc' 'rsbv_bsr' 'rsbv_bdi' 'rsbv_vbr' 'uscr_coo' 'uscr_csc' 'uscr_csr' 'uscr_dia' 'uscr_bco' 'uscr_bsc' 'uscr_bsr' 'uscr_bdi' 'uscr_vbr' 'usds' 'usmm' 'usmv' 'ussm' 'ussv' 'usdot' 'usaxpy' 'usga' 'usgz' 'ussc' 'conv_tools' 'INSERTING' 'INS_ROUTINER' 'uscr_begin' 'uscr_block_begin' 'uscr_variable_block_begin' 'uscr_insert_entry' 'uscr_insert_entries' 'uscr_insert_col' 'uscr_insert_row' 'uscr_insert_clique' 'uscr_insert_block' 'uscr_end' 'usgp' 'ussp' 'usconv_bco2bdi' 'usconv_bdi2bco' 'usconv_coo2csr' 'usconv_coo2csc' 'usconv_bco2bsr' 'usconv_bco2bsc' 'usconv_coo2dia' 'usconv_dia2coo' 'usconv_csr2coo' 'usconv_csc2coo' 'usconv_bsc2bco' 'usconv_bsr2bco' ############################################################################## ############################################################################## do sourcefile=$file'_source.F' targetfile=$file'_target.F' output=$file'.f90' if [ ! -f $DIR_CODE/$output ] then cp $DIR_SOFT/$sourcefile $DIR_WORK cp $DIR_TARGET/$targetfile $DIR_WORK for arith in 'integer' 'doubleComplex' 'doublePrecision' 'singleComplex' 'singlePrecision' do cp $DIR_ARITH/$arith $DIR_WORK cd $DIR_WORK echo '#include "'$arith'"' > dummy.F grep -v '#include' $sourcefile >> dummy.F cpp -P dummy.F | egrep '[0-9]|[a-z]|[A-Z]|\*' | sed -e 's/, ,//g' > $arith$sourcefile rm -f $arith dummy.F cd .. done cd $DIR_WORK rm -f $sourcefile cpp -P $targetfile | egrep '[0-9]|[a-z]|[A-Z]|\*' | sed -e 's/, ,//g' > $output echo $output created rm -f $targetfile *_source* cd .. mv $DIR_WORK/$output $DIR_CODE fi done for file in $DIR_NMODIF/* do if [ ! -f $DIR_CODE/$file ] then cp $file $DIR_CODE fi done rmdir $DIR_WORK ############################################################################## cd $DIR_CODE make SBLAS_ARCH=$SB_ARCH cd .. cd $DIR_TEST make -f "Makefile.$SB_ARCH" SHAR_EOF fi # end of overwriting check if test -f 'README.1st' then echo shar: will not over-write existing file "'README.1st'" else cat << "SHAR_EOF" > 'README.1st' ***************************************************************** * * * SPARSE BLAS IN FORTRAN 95 VERSION May 3, 2002 * * * * IAIN DUFF * * CHRISTOF VOEMEL * * MARCELIN YOUAN * * * * The latest version of the Sparse BLAS package can be * * obtained from the web page * * http://www.cerfacs.fr/~voemel/SparseBLAS/SparseBLAS.html * * * ***************************************************************** 1 Introduction ************** The files in this repository contain an instantiation of the Sparse BLAS in Fortran 95. It conforms with the final draft of the specification. 2 Implemented functionality of Sparse BLAS ****************************************** This repository contains the complete Sparse BLAS functionality as follows: - Level 1 computational routines - Management routines for sparse matrix handles :begin construction routines :Insertion routines :end construction routine :set properties routine :get properties routine - A routine for the release of a created handle - Multiplication of sparse matrix with dense vector or dense matrix - Solution of triangular systems with one or multiple right-hand sides 3 Compilation and tests *********************** The code together with some test routines is built by executing the script "INSTALL" in the current directory. Before execution, the file "INSTALL" has to be opened to set the variable SB_ARCH according to your machine. For example, for an IBM AIX uncomment the line "#SB_ARCH='AIX' #XL Fortran for IBM AIX". Then, the following procedure is invoked: 1. Build the Sparse BLAS source code in the directory "SOFTWARE". 2. Compile the Sparse BLAS and generate the Sparse BLAS library together with the module headers in the directory "SOFTWARE". 3. Compile a test program for the library in the directory "TESTER". This program "test_all" tests the Sparse BLAS functionalities and displays the results. It uses data which is contained in the file "test_parameters.f90". 4. A small sample program for the use of the Sparse BLAS is provided in the file power.f90 that implements a power iteration on a sample matrix. It can be compiled by make -f Makefile.${ARCH} power_method, make sure that the variable SYS_LIB points correctly to the BLAS. 4 For PC users: *************** The following steps describe how to compile the library with the NAG compiler: cd SOFTWARE make SBLAS_ARCH=NAG cd .. cd TESTER make -f Makefile.NAG 5 Code performance: ******************* By default, the software is compiled with debug option "-g". In order to enhance performance, please compile with the appropriate optimization flags (-O3, -Ofast, etc). ****************************** COMMENTS, BUG-REPORTS, etc. to Christof.Voemel@cerfacs.fr. SHAR_EOF fi # end of overwriting check if test ! -d 'SOFTWARE' then mkdir 'SOFTWARE' fi cd 'SOFTWARE' if test -f 'Entry.f90' then echo shar: will not over-write existing file "'Entry.f90'" else cat << "SHAR_EOF" > 'Entry.f90' module mod_Entry use mod_uscr_begin use mod_uscr_end use mod_uscr_insert_entry use mod_uscr_insert_entries use mod_uscr_insert_col use mod_uscr_insert_row use mod_uscr_insert_clique use mod_uscr_insert_block use mod_uscr_block_begin use mod_uscr_variable_block_begin use mod_usgp use mod_ussp use mod_INS_ROUTINER use mod_INSERTING end module mod_Entry SHAR_EOF fi # end of overwriting check if test -f 'INSERTING.f90' then echo shar: will not over-write existing file "'INSERTING.f90'" else cat << "SHAR_EOF" > 'INSERTING.f90' module mod_INSERTING ! ********************************************************************** ! Author : M.YOUAN ! Date of last modification : 24.4.02 ! Description :this module is based one two chained list ( one for ! collection of matrix and a another for elements of each matrix) . ! Subroutines are used to create,accede to,delete components of these ! lists ! ********************************************************************** use blas_sparse_namedconstants use properties implicit none interface access_element module procedure iaccess_element module procedure saccess_element module procedure daccess_element module procedure caccess_element module procedure zaccess_element end interface interface access_matrix module procedure iaccess_matrix module procedure saccess_matrix module procedure daccess_matrix module procedure caccess_matrix module procedure zaccess_matrix end interface !**************************************** type i_inpnt1 integer::row_ind,col_ind integer::value end type i_inpnt1 type i_inblock integer ::row_block_ind,col_block_ind integer,dimension(:,:),pointer::value end type i_inblock type i_invblock integer ::row_vblock_ind,col_vblock_ind integer,dimension(:,:),pointer::value end type i_invblock type i_inelement type(i_inblock)::blin type(i_inpnt1)::pntin type(i_invblock)::vblin end type i_inelement type i_element integer::number type(i_inelement)::contents type(i_element),pointer::pntr end type i_element type i_matrix integer,dimension(6)::DIM integer::property,number,new character*11::format integer,dimension(:),pointer::sub_rows,sub_cols,trb,tre type(i_element),pointer::i_element_start type(i_matrix),pointer::pntr end type i_matrix !**************************************** type d_inpnt1 integer::row_ind,col_ind real(kind=dp)::value end type d_inpnt1 type d_inblock integer ::row_block_ind,col_block_ind real(kind=dp),dimension(:,:),pointer::value end type d_inblock type d_invblock integer ::row_vblock_ind,col_vblock_ind real(kind=dp),dimension(:,:),pointer::value end type d_invblock type d_inelement type(d_inblock)::blin type(d_inpnt1)::pntin type(d_invblock)::vblin end type d_inelement type d_element integer::number type(d_inelement)::contents type(d_element),pointer::pntr end type d_element type d_matrix integer,dimension(6)::DIM integer::property,number,new character*11::format integer,dimension(:),pointer::sub_rows,sub_cols,trb,tre type(d_element),pointer::d_element_start type(d_matrix),pointer::pntr end type d_matrix !***************************************** type s_inpnt1 integer::row_ind,col_ind real(kind=sp)::value end type s_inpnt1 type s_inblock integer ::row_block_ind,col_block_ind real(kind=sp),dimension(:,:),pointer::value end type s_inblock type s_invblock integer ::row_vblock_ind,col_vblock_ind real(kind=sp),dimension(:,:),pointer::value end type s_invblock type s_inelement type(s_inblock)::blin type(s_inpnt1)::pntin type(s_invblock)::vblin end type s_inelement type s_element integer::number type(s_inelement)::contents type(s_element),pointer::pntr end type s_element type s_matrix integer,dimension(6)::DIM integer::property,number,new character*11::format integer,dimension(:),pointer::sub_rows,sub_cols,trb,tre type(s_element),pointer::s_element_start type(s_matrix),pointer::pntr end type s_matrix !**************************************** type c_inpnt1 integer::row_ind,col_ind complex(kind=sp)::value end type c_inpnt1 type c_inblock integer ::row_block_ind,col_block_ind complex(kind=sp),dimension(:,:),pointer::value end type c_inblock type c_invblock integer ::row_vblock_ind,col_vblock_ind complex(kind=sp),dimension(:,:),pointer::value end type c_invblock type c_inelement type(c_inblock)::blin type(c_inpnt1)::pntin type(c_invblock)::vblin end type c_inelement type c_element integer::number type(c_inelement)::contents type(c_element),pointer::pntr end type c_element type c_matrix integer,dimension(6)::DIM integer::property,number,new character*11::format integer,dimension(:),pointer::sub_rows,sub_cols,trb,tre type(c_element),pointer::c_element_start type(c_matrix),pointer::pntr end type c_matrix !**************************************** type z_inpnt1 integer::row_ind,col_ind complex(kind=dp)::value end type z_inpnt1 type z_inblock integer ::row_block_ind,col_block_ind complex(kind=dp),dimension(:,:),pointer::value end type z_inblock type z_invblock integer ::row_vblock_ind,col_vblock_ind complex(kind=dp),dimension(:,:),pointer::value end type z_invblock type z_inelement type(z_inblock)::blin type(z_inpnt1)::pntin type(z_invblock)::vblin end type z_inelement type z_element integer::number type(z_inelement)::contents type(z_element),pointer::pntr end type z_element type z_matrix integer,dimension(6)::DIM integer::property,number,new character*11::format integer,dimension(:),pointer::sub_rows,sub_cols,trb,tre type(z_element),pointer::z_element_start type(z_matrix),pointer::pntr end type z_matrix !***************************************** type(i_matrix), pointer,SAVE :: i_matrix_start type(d_matrix), pointer,SAVE :: d_matrix_start type(s_matrix), pointer,SAVE :: s_matrix_start type(c_matrix), pointer,SAVE :: c_matrix_start type(z_matrix), pointer,SAVE :: z_matrix_start logical, SAVE, PRIVATE :: iins_init = .FALSE. logical, SAVE, PRIVATE :: dins_init = .FALSE. logical, SAVE, PRIVATE :: sins_init = .FALSE. logical, SAVE, PRIVATE :: cins_init = .FALSE. logical, SAVE, PRIVATE :: zins_init = .FALSE. contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine new_i_matrix (nmb,Mb,ierr) implicit none integer ,intent(out)::nmb,ierr integer ,intent(in)::Mb type(i_matrix ),pointer::matrix_insert if (.NOT. iins_init ) then nullify(i_matrix_start ) iins_init = .TRUE. end if if (.not.associated(i_matrix_start )) then allocate(i_matrix_start ,STAT=ierr) i_matrix_start %number= ISP_MATRIX i_matrix_start %number=- i_matrix_start %number nullify(i_matrix_start %pntr) else allocate(matrix_insert,STAT=ierr) matrix_insert%number= i_matrix_start %number-no_of_types matrix_insert%pntr=> i_matrix_start i_matrix_start => matrix_insert end if i_matrix_start %DIM=0 i_matrix_start %property=blas_general+blas_one_base+blas_col_major i_matrix_start %new = 1 !new=0:blas_open_handle, new=1: blas_new_handle i_matrix_start %format='' nullify(i_matrix_start %sub_rows,i_matrix_start %sub_cols) nullify(i_matrix_start % i_element_start ) allocate(i_matrix_start %trb(Mb),i_matrix_start %tre(Mb)) nmb= i_matrix_start %number ierr=0 end subroutine new_i_matrix !* subroutine dealloc_i_matrix (nmb,ierr) implicit none integer ,intent(in)::nmb integer ,intent(out)::ierr type(i_matrix ),pointer ::matrix_precedent,matrix_tester ierr=-1 if(.not.associated(i_matrix_start %pntr)) then if(i_matrix_start %number.eq.nmb) then deallocate(i_matrix_start %tre,i_matrix_start %trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(i_matrix_start ,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if nullify(i_matrix_start ) ierr=0 return end if else matrix_tester=> i_matrix_start if(matrix_tester%number.eq.nmb) then i_matrix_start =>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return endif matrix_precedent=> i_matrix_start matrix_tester=> i_matrix_start %pntr do while((associated(matrix_tester))) if(matrix_tester%number.eq.nmb) then matrix_precedent%pntr=>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return else matrix_precedent=>matrix_tester matrix_tester=>matrix_tester%pntr end if end do end if end subroutine dealloc_i_matrix !* subroutine iaccess_matrix (pmatrix,nmb,istat) implicit none type(i_matrix ),pointer ::pmatrix integer,intent(out)::istat integer,intent(in) ::nmb type(i_matrix ),pointer ::matrix_tester istat=-1 matrix_tester=> i_matrix_start do while((matrix_tester%number.ne.nmb).and.& (associated(matrix_tester%pntr))) matrix_tester => matrix_tester%pntr end do if (matrix_tester%number.eq.nmb) then pmatrix => matrix_tester istat = 0 return else nullify(pmatrix) istat = blas_error_param end if end subroutine iaccess_matrix !* subroutine new_i_element (pmatrix,nmb_element,istat) implicit none type(i_matrix ),pointer::pmatrix integer,intent(out)::nmb_element,istat type(i_element ),pointer::element_insert integer :: ierr istat = -1 if (.not.associated(pmatrix% i_element_start )) then pmatrix%new=0 !status changed to blas_open_handle allocate(pmatrix% i_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if pmatrix% i_element_start %number=1 !will certainly changed nullify(pmatrix% i_element_start %pntr) else allocate(element_insert,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if element_insert%pntr=>pmatrix% i_element_start element_insert%number=pmatrix% i_element_start %number+1 pmatrix% i_element_start => element_insert end if select case(pmatrix%format) case('normal') pmatrix% i_element_start %contents%pntin%value=0 pmatrix% i_element_start %contents%pntin%row_ind=-1 pmatrix% i_element_start %contents%pntin%col_ind=-1 nullify(pmatrix% i_element_start %contents%blin%value) nullify(pmatrix% i_element_start %contents%vblin%value) case('block') nullify(pmatrix% i_element_start %contents%blin%value) nullify(pmatrix% i_element_start %contents%vblin%value) pmatrix% i_element_start %contents%blin%row_block_ind=-1 pmatrix% i_element_start %contents%blin%col_block_ind=-1 case('vblock') nullify(pmatrix% i_element_start %contents%blin%value) nullify(pmatrix% i_element_start %contents%vblin%value) pmatrix% i_element_start %contents%vblin%row_vblock_ind=-1 pmatrix% i_element_start %contents%vblin%col_vblock_ind=-1 case default istat = blas_error_param return end select nmb_element=pmatrix% i_element_start %number istat=0 end subroutine new_i_element !* subroutine dealloc_i_element (nmb_element,pmatrix,istat) implicit none integer ,intent(in)::nmb_element type(i_matrix ),pointer::pmatrix integer ,intent(out)::istat type(i_element ),pointer ::element_tester integer::ierr istat=-1 if(.not.associated( pmatrix% i_element_start %pntr)) then if(pmatrix% i_element_start %number.eq.nmb_element) then if(associated(pmatrix% i_element_start %contents%vblin%value))& then deallocate(pmatrix% i_element_start %contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(pmatrix% i_element_start %contents%blin%value))& then deallocate(pmatrix% i_element_start %contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(pmatrix% i_element_start )) then deallocate(pmatrix% i_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if nullify(pmatrix% i_element_start ) end if istat = 0 return else element_tester=>pmatrix% i_element_start if(element_tester%number.eq.nmb_element) then pmatrix% i_element_start =>element_tester%pntr if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return endif element_tester=>pmatrix% i_element_start %pntr do while((associated(element_tester))) if(element_tester%number.eq.nmb_element) then if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return else element_tester=>element_tester%pntr end if end do end if end subroutine dealloc_i_element !* subroutine iaccess_element (pelement,nmb_element,& pmatrix,istat) implicit none type(i_inelement ),pointer::pelement integer,intent(in) ::nmb_element type(i_matrix ),pointer::pmatrix integer,intent(out)::istat type(i_element ),pointer ::element_tester istat=-1 element_tester=>pmatrix% i_element_start do while((element_tester%number.ne.nmb_element)& .and.(associated(element_tester%pntr))) element_tester => element_tester%pntr end do if (element_tester%number.eq.nmb_element) then pelement => element_tester%contents istat = 0 return else nullify(pelement) istat = blas_error_param return end if end subroutine iaccess_element !* subroutine i_element_num (nmb_element,pmatrix,i,j,istat) implicit none integer,intent(out),target::nmb_element type(i_matrix ),pointer::pmatrix integer ,intent(in)::i,j integer,intent(out)::istat type(i_element ),pointer ::element_tester logical:: finder istat = -1 select case(pmatrix%format) case('normal') element_tester=>pmatrix% i_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j)) then nmb_element=element_tester%number else nmb_element=0 end if end if case('block') element_tester=>pmatrix% i_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case('vblock') element_tester=>pmatrix% i_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr)).and.& (.not.finder)) if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case default istat = blas_error_param return end select istat = 0 end subroutine i_element_num !* subroutine i_dealloc (nmb,istat) implicit none integer,intent(in)::nmb integer,intent(out)::istat type(i_matrix ),pointer::pmatrix type(i_element ),pointer ::element_tester,next_element istat = -1 call iaccess_matrix (pmatrix,nmb,istat) if (istat.ne.0) return element_tester=>pmatrix% i_element_start if(.not.associated(element_tester%pntr)) then call dealloc_i_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return else next_element=>element_tester%pntr do while((associated(next_element))) call dealloc_i_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return element_tester=>next_element next_element=>element_tester%pntr end do call dealloc_i_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return end if call dealloc_i_matrix (nmb,istat) if (istat.ne.0) return istat = 0 return end subroutine i_dealloc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine new_s_matrix (nmb,Mb,ierr) implicit none integer ,intent(out)::nmb,ierr integer ,intent(in)::Mb type(s_matrix ),pointer::matrix_insert if (.NOT. sins_init ) then nullify(s_matrix_start ) sins_init = .TRUE. end if if (.not.associated(s_matrix_start )) then allocate(s_matrix_start ,STAT=ierr) s_matrix_start %number= SSP_MATRIX s_matrix_start %number=- s_matrix_start %number nullify(s_matrix_start %pntr) else allocate(matrix_insert,STAT=ierr) matrix_insert%number= s_matrix_start %number-no_of_types matrix_insert%pntr=> s_matrix_start s_matrix_start => matrix_insert end if s_matrix_start %DIM=0 s_matrix_start %property=blas_general+blas_one_base+blas_col_major s_matrix_start %new = 1 !new=0:blas_open_handle, new=1: blas_new_handle s_matrix_start %format='' nullify(s_matrix_start %sub_rows,s_matrix_start %sub_cols) nullify(s_matrix_start % s_element_start ) allocate(s_matrix_start %trb(Mb),s_matrix_start %tre(Mb)) nmb= s_matrix_start %number ierr=0 end subroutine new_s_matrix !* subroutine dealloc_s_matrix (nmb,ierr) implicit none integer ,intent(in)::nmb integer ,intent(out)::ierr type(s_matrix ),pointer ::matrix_precedent,matrix_tester ierr=-1 if(.not.associated(s_matrix_start %pntr)) then if(s_matrix_start %number.eq.nmb) then deallocate(s_matrix_start %tre,s_matrix_start %trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(s_matrix_start ,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if nullify(s_matrix_start ) ierr=0 return end if else matrix_tester=> s_matrix_start if(matrix_tester%number.eq.nmb) then s_matrix_start =>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return endif matrix_precedent=> s_matrix_start matrix_tester=> s_matrix_start %pntr do while((associated(matrix_tester))) if(matrix_tester%number.eq.nmb) then matrix_precedent%pntr=>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return else matrix_precedent=>matrix_tester matrix_tester=>matrix_tester%pntr end if end do end if end subroutine dealloc_s_matrix !* subroutine saccess_matrix (pmatrix,nmb,istat) implicit none type(s_matrix ),pointer ::pmatrix integer,intent(out)::istat integer,intent(in) ::nmb type(s_matrix ),pointer ::matrix_tester istat=-1 matrix_tester=> s_matrix_start do while((matrix_tester%number.ne.nmb).and.& (associated(matrix_tester%pntr))) matrix_tester => matrix_tester%pntr end do if (matrix_tester%number.eq.nmb) then pmatrix => matrix_tester istat = 0 return else nullify(pmatrix) istat = blas_error_param end if end subroutine saccess_matrix !* subroutine new_s_element (pmatrix,nmb_element,istat) implicit none type(s_matrix ),pointer::pmatrix integer,intent(out)::nmb_element,istat type(s_element ),pointer::element_insert integer :: ierr istat = -1 if (.not.associated(pmatrix% s_element_start )) then pmatrix%new=0 !status changed to blas_open_handle allocate(pmatrix% s_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if pmatrix% s_element_start %number=1 !will certainly changed nullify(pmatrix% s_element_start %pntr) else allocate(element_insert,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if element_insert%pntr=>pmatrix% s_element_start element_insert%number=pmatrix% s_element_start %number+1 pmatrix% s_element_start => element_insert end if select case(pmatrix%format) case('normal') pmatrix% s_element_start %contents%pntin%value=0 pmatrix% s_element_start %contents%pntin%row_ind=-1 pmatrix% s_element_start %contents%pntin%col_ind=-1 nullify(pmatrix% s_element_start %contents%blin%value) nullify(pmatrix% s_element_start %contents%vblin%value) case('block') nullify(pmatrix% s_element_start %contents%blin%value) nullify(pmatrix% s_element_start %contents%vblin%value) pmatrix% s_element_start %contents%blin%row_block_ind=-1 pmatrix% s_element_start %contents%blin%col_block_ind=-1 case('vblock') nullify(pmatrix% s_element_start %contents%blin%value) nullify(pmatrix% s_element_start %contents%vblin%value) pmatrix% s_element_start %contents%vblin%row_vblock_ind=-1 pmatrix% s_element_start %contents%vblin%col_vblock_ind=-1 case default istat = blas_error_param return end select nmb_element=pmatrix% s_element_start %number istat=0 end subroutine new_s_element !* subroutine dealloc_s_element (nmb_element,pmatrix,istat) implicit none integer ,intent(in)::nmb_element type(s_matrix ),pointer::pmatrix integer ,intent(out)::istat type(s_element ),pointer ::element_tester integer::ierr istat=-1 if(.not.associated( pmatrix% s_element_start %pntr)) then if(pmatrix% s_element_start %number.eq.nmb_element) then if(associated(pmatrix% s_element_start %contents%vblin%value))& then deallocate(pmatrix% s_element_start %contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(pmatrix% s_element_start %contents%blin%value))& then deallocate(pmatrix% s_element_start %contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(pmatrix% s_element_start )) then deallocate(pmatrix% s_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if nullify(pmatrix% s_element_start ) end if istat = 0 return else element_tester=>pmatrix% s_element_start if(element_tester%number.eq.nmb_element) then pmatrix% s_element_start =>element_tester%pntr if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return endif element_tester=>pmatrix% s_element_start %pntr do while((associated(element_tester))) if(element_tester%number.eq.nmb_element) then if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return else element_tester=>element_tester%pntr end if end do end if end subroutine dealloc_s_element !* subroutine saccess_element (pelement,nmb_element,& pmatrix,istat) implicit none type(s_inelement ),pointer::pelement integer,intent(in) ::nmb_element type(s_matrix ),pointer::pmatrix integer,intent(out)::istat type(s_element ),pointer ::element_tester istat=-1 element_tester=>pmatrix% s_element_start do while((element_tester%number.ne.nmb_element)& .and.(associated(element_tester%pntr))) element_tester => element_tester%pntr end do if (element_tester%number.eq.nmb_element) then pelement => element_tester%contents istat = 0 return else nullify(pelement) istat = blas_error_param return end if end subroutine saccess_element !* subroutine s_element_num (nmb_element,pmatrix,i,j,istat) implicit none integer,intent(out),target::nmb_element type(s_matrix ),pointer::pmatrix integer ,intent(in)::i,j integer,intent(out)::istat type(s_element ),pointer ::element_tester logical:: finder istat = -1 select case(pmatrix%format) case('normal') element_tester=>pmatrix% s_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j)) then nmb_element=element_tester%number else nmb_element=0 end if end if case('block') element_tester=>pmatrix% s_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case('vblock') element_tester=>pmatrix% s_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr)).and.& (.not.finder)) if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case default istat = blas_error_param return end select istat = 0 end subroutine s_element_num !* subroutine s_dealloc (nmb,istat) implicit none integer,intent(in)::nmb integer,intent(out)::istat type(s_matrix ),pointer::pmatrix type(s_element ),pointer ::element_tester,next_element istat = -1 call saccess_matrix (pmatrix,nmb,istat) if (istat.ne.0) return element_tester=>pmatrix% s_element_start if(.not.associated(element_tester%pntr)) then call dealloc_s_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return else next_element=>element_tester%pntr do while((associated(next_element))) call dealloc_s_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return element_tester=>next_element next_element=>element_tester%pntr end do call dealloc_s_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return end if call dealloc_s_matrix (nmb,istat) if (istat.ne.0) return istat = 0 return end subroutine s_dealloc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine new_d_matrix (nmb,Mb,ierr) implicit none integer ,intent(out)::nmb,ierr integer ,intent(in)::Mb type(d_matrix ),pointer::matrix_insert if (.NOT. dins_init ) then nullify(d_matrix_start ) dins_init = .TRUE. end if if (.not.associated(d_matrix_start )) then allocate(d_matrix_start ,STAT=ierr) d_matrix_start %number= DSP_MATRIX d_matrix_start %number=- d_matrix_start %number nullify(d_matrix_start %pntr) else allocate(matrix_insert,STAT=ierr) matrix_insert%number= d_matrix_start %number-no_of_types matrix_insert%pntr=> d_matrix_start d_matrix_start => matrix_insert end if d_matrix_start %DIM=0 d_matrix_start %property=blas_general+blas_one_base+blas_col_major d_matrix_start %new = 1 !new=0:blas_open_handle, new=1: blas_new_handle d_matrix_start %format='' nullify(d_matrix_start %sub_rows,d_matrix_start %sub_cols) nullify(d_matrix_start % d_element_start ) allocate(d_matrix_start %trb(Mb),d_matrix_start %tre(Mb)) nmb= d_matrix_start %number ierr=0 end subroutine new_d_matrix !* subroutine dealloc_d_matrix (nmb,ierr) implicit none integer ,intent(in)::nmb integer ,intent(out)::ierr type(d_matrix ),pointer ::matrix_precedent,matrix_tester ierr=-1 if(.not.associated(d_matrix_start %pntr)) then if(d_matrix_start %number.eq.nmb) then deallocate(d_matrix_start %tre,d_matrix_start %trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(d_matrix_start ,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if nullify(d_matrix_start ) ierr=0 return end if else matrix_tester=> d_matrix_start if(matrix_tester%number.eq.nmb) then d_matrix_start =>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return endif matrix_precedent=> d_matrix_start matrix_tester=> d_matrix_start %pntr do while((associated(matrix_tester))) if(matrix_tester%number.eq.nmb) then matrix_precedent%pntr=>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return else matrix_precedent=>matrix_tester matrix_tester=>matrix_tester%pntr end if end do end if end subroutine dealloc_d_matrix !* subroutine daccess_matrix (pmatrix,nmb,istat) implicit none type(d_matrix ),pointer ::pmatrix integer,intent(out)::istat integer,intent(in) ::nmb type(d_matrix ),pointer ::matrix_tester istat=-1 matrix_tester=> d_matrix_start do while((matrix_tester%number.ne.nmb).and.& (associated(matrix_tester%pntr))) matrix_tester => matrix_tester%pntr end do if (matrix_tester%number.eq.nmb) then pmatrix => matrix_tester istat = 0 return else nullify(pmatrix) istat = blas_error_param end if end subroutine daccess_matrix !* subroutine new_d_element (pmatrix,nmb_element,istat) implicit none type(d_matrix ),pointer::pmatrix integer,intent(out)::nmb_element,istat type(d_element ),pointer::element_insert integer :: ierr istat = -1 if (.not.associated(pmatrix% d_element_start )) then pmatrix%new=0 !status changed to blas_open_handle allocate(pmatrix% d_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if pmatrix% d_element_start %number=1 !will certainly changed nullify(pmatrix% d_element_start %pntr) else allocate(element_insert,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if element_insert%pntr=>pmatrix% d_element_start element_insert%number=pmatrix% d_element_start %number+1 pmatrix% d_element_start => element_insert end if select case(pmatrix%format) case('normal') pmatrix% d_element_start %contents%pntin%value=0 pmatrix% d_element_start %contents%pntin%row_ind=-1 pmatrix% d_element_start %contents%pntin%col_ind=-1 nullify(pmatrix% d_element_start %contents%blin%value) nullify(pmatrix% d_element_start %contents%vblin%value) case('block') nullify(pmatrix% d_element_start %contents%blin%value) nullify(pmatrix% d_element_start %contents%vblin%value) pmatrix% d_element_start %contents%blin%row_block_ind=-1 pmatrix% d_element_start %contents%blin%col_block_ind=-1 case('vblock') nullify(pmatrix% d_element_start %contents%blin%value) nullify(pmatrix% d_element_start %contents%vblin%value) pmatrix% d_element_start %contents%vblin%row_vblock_ind=-1 pmatrix% d_element_start %contents%vblin%col_vblock_ind=-1 case default istat = blas_error_param return end select nmb_element=pmatrix% d_element_start %number istat=0 end subroutine new_d_element !* subroutine dealloc_d_element (nmb_element,pmatrix,istat) implicit none integer ,intent(in)::nmb_element type(d_matrix ),pointer::pmatrix integer ,intent(out)::istat type(d_element ),pointer ::element_tester integer::ierr istat=-1 if(.not.associated( pmatrix% d_element_start %pntr)) then if(pmatrix% d_element_start %number.eq.nmb_element) then if(associated(pmatrix% d_element_start %contents%vblin%value))& then deallocate(pmatrix% d_element_start %contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(pmatrix% d_element_start %contents%blin%value))& then deallocate(pmatrix% d_element_start %contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(pmatrix% d_element_start )) then deallocate(pmatrix% d_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if nullify(pmatrix% d_element_start ) end if istat = 0 return else element_tester=>pmatrix% d_element_start if(element_tester%number.eq.nmb_element) then pmatrix% d_element_start =>element_tester%pntr if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return endif element_tester=>pmatrix% d_element_start %pntr do while((associated(element_tester))) if(element_tester%number.eq.nmb_element) then if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return else element_tester=>element_tester%pntr end if end do end if end subroutine dealloc_d_element !* subroutine daccess_element (pelement,nmb_element,& pmatrix,istat) implicit none type(d_inelement ),pointer::pelement integer,intent(in) ::nmb_element type(d_matrix ),pointer::pmatrix integer,intent(out)::istat type(d_element ),pointer ::element_tester istat=-1 element_tester=>pmatrix% d_element_start do while((element_tester%number.ne.nmb_element)& .and.(associated(element_tester%pntr))) element_tester => element_tester%pntr end do if (element_tester%number.eq.nmb_element) then pelement => element_tester%contents istat = 0 return else nullify(pelement) istat = blas_error_param return end if end subroutine daccess_element !* subroutine d_element_num (nmb_element,pmatrix,i,j,istat) implicit none integer,intent(out),target::nmb_element type(d_matrix ),pointer::pmatrix integer ,intent(in)::i,j integer,intent(out)::istat type(d_element ),pointer ::element_tester logical:: finder istat = -1 select case(pmatrix%format) case('normal') element_tester=>pmatrix% d_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j)) then nmb_element=element_tester%number else nmb_element=0 end if end if case('block') element_tester=>pmatrix% d_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case('vblock') element_tester=>pmatrix% d_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr)).and.& (.not.finder)) if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case default istat = blas_error_param return end select istat = 0 end subroutine d_element_num !* subroutine d_dealloc (nmb,istat) implicit none integer,intent(in)::nmb integer,intent(out)::istat type(d_matrix ),pointer::pmatrix type(d_element ),pointer ::element_tester,next_element istat = -1 call daccess_matrix (pmatrix,nmb,istat) if (istat.ne.0) return element_tester=>pmatrix% d_element_start if(.not.associated(element_tester%pntr)) then call dealloc_d_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return else next_element=>element_tester%pntr do while((associated(next_element))) call dealloc_d_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return element_tester=>next_element next_element=>element_tester%pntr end do call dealloc_d_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return end if call dealloc_d_matrix (nmb,istat) if (istat.ne.0) return istat = 0 return end subroutine d_dealloc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine new_c_matrix (nmb,Mb,ierr) implicit none integer ,intent(out)::nmb,ierr integer ,intent(in)::Mb type(c_matrix ),pointer::matrix_insert if (.NOT. cins_init ) then nullify(c_matrix_start ) cins_init = .TRUE. end if if (.not.associated(c_matrix_start )) then allocate(c_matrix_start ,STAT=ierr) c_matrix_start %number= CSP_MATRIX c_matrix_start %number=- c_matrix_start %number nullify(c_matrix_start %pntr) else allocate(matrix_insert,STAT=ierr) matrix_insert%number= c_matrix_start %number-no_of_types matrix_insert%pntr=> c_matrix_start c_matrix_start => matrix_insert end if c_matrix_start %DIM=0 c_matrix_start %property=blas_general+blas_one_base+blas_col_major c_matrix_start %new = 1 !new=0:blas_open_handle, new=1: blas_new_handle c_matrix_start %format='' nullify(c_matrix_start %sub_rows,c_matrix_start %sub_cols) nullify(c_matrix_start % c_element_start ) allocate(c_matrix_start %trb(Mb),c_matrix_start %tre(Mb)) nmb= c_matrix_start %number ierr=0 end subroutine new_c_matrix !* subroutine dealloc_c_matrix (nmb,ierr) implicit none integer ,intent(in)::nmb integer ,intent(out)::ierr type(c_matrix ),pointer ::matrix_precedent,matrix_tester ierr=-1 if(.not.associated(c_matrix_start %pntr)) then if(c_matrix_start %number.eq.nmb) then deallocate(c_matrix_start %tre,c_matrix_start %trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(c_matrix_start ,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if nullify(c_matrix_start ) ierr=0 return end if else matrix_tester=> c_matrix_start if(matrix_tester%number.eq.nmb) then c_matrix_start =>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return endif matrix_precedent=> c_matrix_start matrix_tester=> c_matrix_start %pntr do while((associated(matrix_tester))) if(matrix_tester%number.eq.nmb) then matrix_precedent%pntr=>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return else matrix_precedent=>matrix_tester matrix_tester=>matrix_tester%pntr end if end do end if end subroutine dealloc_c_matrix !* subroutine caccess_matrix (pmatrix,nmb,istat) implicit none type(c_matrix ),pointer ::pmatrix integer,intent(out)::istat integer,intent(in) ::nmb type(c_matrix ),pointer ::matrix_tester istat=-1 matrix_tester=> c_matrix_start do while((matrix_tester%number.ne.nmb).and.& (associated(matrix_tester%pntr))) matrix_tester => matrix_tester%pntr end do if (matrix_tester%number.eq.nmb) then pmatrix => matrix_tester istat = 0 return else nullify(pmatrix) istat = blas_error_param end if end subroutine caccess_matrix !* subroutine new_c_element (pmatrix,nmb_element,istat) implicit none type(c_matrix ),pointer::pmatrix integer,intent(out)::nmb_element,istat type(c_element ),pointer::element_insert integer :: ierr istat = -1 if (.not.associated(pmatrix% c_element_start )) then pmatrix%new=0 !status changed to blas_open_handle allocate(pmatrix% c_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if pmatrix% c_element_start %number=1 !will certainly changed nullify(pmatrix% c_element_start %pntr) else allocate(element_insert,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if element_insert%pntr=>pmatrix% c_element_start element_insert%number=pmatrix% c_element_start %number+1 pmatrix% c_element_start => element_insert end if select case(pmatrix%format) case('normal') pmatrix% c_element_start %contents%pntin%value=0 pmatrix% c_element_start %contents%pntin%row_ind=-1 pmatrix% c_element_start %contents%pntin%col_ind=-1 nullify(pmatrix% c_element_start %contents%blin%value) nullify(pmatrix% c_element_start %contents%vblin%value) case('block') nullify(pmatrix% c_element_start %contents%blin%value) nullify(pmatrix% c_element_start %contents%vblin%value) pmatrix% c_element_start %contents%blin%row_block_ind=-1 pmatrix% c_element_start %contents%blin%col_block_ind=-1 case('vblock') nullify(pmatrix% c_element_start %contents%blin%value) nullify(pmatrix% c_element_start %contents%vblin%value) pmatrix% c_element_start %contents%vblin%row_vblock_ind=-1 pmatrix% c_element_start %contents%vblin%col_vblock_ind=-1 case default istat = blas_error_param return end select nmb_element=pmatrix% c_element_start %number istat=0 end subroutine new_c_element !* subroutine dealloc_c_element (nmb_element,pmatrix,istat) implicit none integer ,intent(in)::nmb_element type(c_matrix ),pointer::pmatrix integer ,intent(out)::istat type(c_element ),pointer ::element_tester integer::ierr istat=-1 if(.not.associated( pmatrix% c_element_start %pntr)) then if(pmatrix% c_element_start %number.eq.nmb_element) then if(associated(pmatrix% c_element_start %contents%vblin%value))& then deallocate(pmatrix% c_element_start %contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(pmatrix% c_element_start %contents%blin%value))& then deallocate(pmatrix% c_element_start %contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(pmatrix% c_element_start )) then deallocate(pmatrix% c_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if nullify(pmatrix% c_element_start ) end if istat = 0 return else element_tester=>pmatrix% c_element_start if(element_tester%number.eq.nmb_element) then pmatrix% c_element_start =>element_tester%pntr if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return endif element_tester=>pmatrix% c_element_start %pntr do while((associated(element_tester))) if(element_tester%number.eq.nmb_element) then if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return else element_tester=>element_tester%pntr end if end do end if end subroutine dealloc_c_element !* subroutine caccess_element (pelement,nmb_element,& pmatrix,istat) implicit none type(c_inelement ),pointer::pelement integer,intent(in) ::nmb_element type(c_matrix ),pointer::pmatrix integer,intent(out)::istat type(c_element ),pointer ::element_tester istat=-1 element_tester=>pmatrix% c_element_start do while((element_tester%number.ne.nmb_element)& .and.(associated(element_tester%pntr))) element_tester => element_tester%pntr end do if (element_tester%number.eq.nmb_element) then pelement => element_tester%contents istat = 0 return else nullify(pelement) istat = blas_error_param return end if end subroutine caccess_element !* subroutine c_element_num (nmb_element,pmatrix,i,j,istat) implicit none integer,intent(out),target::nmb_element type(c_matrix ),pointer::pmatrix integer ,intent(in)::i,j integer,intent(out)::istat type(c_element ),pointer ::element_tester logical:: finder istat = -1 select case(pmatrix%format) case('normal') element_tester=>pmatrix% c_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j)) then nmb_element=element_tester%number else nmb_element=0 end if end if case('block') element_tester=>pmatrix% c_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case('vblock') element_tester=>pmatrix% c_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr)).and.& (.not.finder)) if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case default istat = blas_error_param return end select istat = 0 end subroutine c_element_num !* subroutine c_dealloc (nmb,istat) implicit none integer,intent(in)::nmb integer,intent(out)::istat type(c_matrix ),pointer::pmatrix type(c_element ),pointer ::element_tester,next_element istat = -1 call caccess_matrix (pmatrix,nmb,istat) if (istat.ne.0) return element_tester=>pmatrix% c_element_start if(.not.associated(element_tester%pntr)) then call dealloc_c_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return else next_element=>element_tester%pntr do while((associated(next_element))) call dealloc_c_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return element_tester=>next_element next_element=>element_tester%pntr end do call dealloc_c_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return end if call dealloc_c_matrix (nmb,istat) if (istat.ne.0) return istat = 0 return end subroutine c_dealloc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine new_z_matrix (nmb,Mb,ierr) implicit none integer ,intent(out)::nmb,ierr integer ,intent(in)::Mb type(z_matrix ),pointer::matrix_insert if (.NOT. zins_init ) then nullify(z_matrix_start ) zins_init = .TRUE. end if if (.not.associated(z_matrix_start )) then allocate(z_matrix_start ,STAT=ierr) z_matrix_start %number= ZSP_MATRIX z_matrix_start %number=- z_matrix_start %number nullify(z_matrix_start %pntr) else allocate(matrix_insert,STAT=ierr) matrix_insert%number= z_matrix_start %number-no_of_types matrix_insert%pntr=> z_matrix_start z_matrix_start => matrix_insert end if z_matrix_start %DIM=0 z_matrix_start %property=blas_general+blas_one_base+blas_col_major z_matrix_start %new = 1 !new=0:blas_open_handle, new=1: blas_new_handle z_matrix_start %format='' nullify(z_matrix_start %sub_rows,z_matrix_start %sub_cols) nullify(z_matrix_start % z_element_start ) allocate(z_matrix_start %trb(Mb),z_matrix_start %tre(Mb)) nmb= z_matrix_start %number ierr=0 end subroutine new_z_matrix !* subroutine dealloc_z_matrix (nmb,ierr) implicit none integer ,intent(in)::nmb integer ,intent(out)::ierr type(z_matrix ),pointer ::matrix_precedent,matrix_tester ierr=-1 if(.not.associated(z_matrix_start %pntr)) then if(z_matrix_start %number.eq.nmb) then deallocate(z_matrix_start %tre,z_matrix_start %trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(z_matrix_start ,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if nullify(z_matrix_start ) ierr=0 return end if else matrix_tester=> z_matrix_start if(matrix_tester%number.eq.nmb) then z_matrix_start =>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return endif matrix_precedent=> z_matrix_start matrix_tester=> z_matrix_start %pntr do while((associated(matrix_tester))) if(matrix_tester%number.eq.nmb) then matrix_precedent%pntr=>matrix_tester%pntr deallocate(matrix_tester%tre,matrix_tester%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(matrix_tester,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ierr=0 return else matrix_precedent=>matrix_tester matrix_tester=>matrix_tester%pntr end if end do end if end subroutine dealloc_z_matrix !* subroutine zaccess_matrix (pmatrix,nmb,istat) implicit none type(z_matrix ),pointer ::pmatrix integer,intent(out)::istat integer,intent(in) ::nmb type(z_matrix ),pointer ::matrix_tester istat=-1 matrix_tester=> z_matrix_start do while((matrix_tester%number.ne.nmb).and.& (associated(matrix_tester%pntr))) matrix_tester => matrix_tester%pntr end do if (matrix_tester%number.eq.nmb) then pmatrix => matrix_tester istat = 0 return else nullify(pmatrix) istat = blas_error_param end if end subroutine zaccess_matrix !* subroutine new_z_element (pmatrix,nmb_element,istat) implicit none type(z_matrix ),pointer::pmatrix integer,intent(out)::nmb_element,istat type(z_element ),pointer::element_insert integer :: ierr istat = -1 if (.not.associated(pmatrix% z_element_start )) then pmatrix%new=0 !status changed to blas_open_handle allocate(pmatrix% z_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if pmatrix% z_element_start %number=1 !will certainly changed nullify(pmatrix% z_element_start %pntr) else allocate(element_insert,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if element_insert%pntr=>pmatrix% z_element_start element_insert%number=pmatrix% z_element_start %number+1 pmatrix% z_element_start => element_insert end if select case(pmatrix%format) case('normal') pmatrix% z_element_start %contents%pntin%value=0 pmatrix% z_element_start %contents%pntin%row_ind=-1 pmatrix% z_element_start %contents%pntin%col_ind=-1 nullify(pmatrix% z_element_start %contents%blin%value) nullify(pmatrix% z_element_start %contents%vblin%value) case('block') nullify(pmatrix% z_element_start %contents%blin%value) nullify(pmatrix% z_element_start %contents%vblin%value) pmatrix% z_element_start %contents%blin%row_block_ind=-1 pmatrix% z_element_start %contents%blin%col_block_ind=-1 case('vblock') nullify(pmatrix% z_element_start %contents%blin%value) nullify(pmatrix% z_element_start %contents%vblin%value) pmatrix% z_element_start %contents%vblin%row_vblock_ind=-1 pmatrix% z_element_start %contents%vblin%col_vblock_ind=-1 case default istat = blas_error_param return end select nmb_element=pmatrix% z_element_start %number istat=0 end subroutine new_z_element !* subroutine dealloc_z_element (nmb_element,pmatrix,istat) implicit none integer ,intent(in)::nmb_element type(z_matrix ),pointer::pmatrix integer ,intent(out)::istat type(z_element ),pointer ::element_tester integer::ierr istat=-1 if(.not.associated( pmatrix% z_element_start %pntr)) then if(pmatrix% z_element_start %number.eq.nmb_element) then if(associated(pmatrix% z_element_start %contents%vblin%value))& then deallocate(pmatrix% z_element_start %contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(pmatrix% z_element_start %contents%blin%value))& then deallocate(pmatrix% z_element_start %contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(pmatrix% z_element_start )) then deallocate(pmatrix% z_element_start ,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if nullify(pmatrix% z_element_start ) end if istat = 0 return else element_tester=>pmatrix% z_element_start if(element_tester%number.eq.nmb_element) then pmatrix% z_element_start =>element_tester%pntr if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return endif element_tester=>pmatrix% z_element_start %pntr do while((associated(element_tester))) if(element_tester%number.eq.nmb_element) then if(associated(element_tester%contents%vblin%value)) then deallocate(element_tester%contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(element_tester%contents%blin%value)) then deallocate(element_tester%contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(element_tester)) then deallocate(element_tester,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if istat=0 return else element_tester=>element_tester%pntr end if end do end if end subroutine dealloc_z_element !* subroutine zaccess_element (pelement,nmb_element,& pmatrix,istat) implicit none type(z_inelement ),pointer::pelement integer,intent(in) ::nmb_element type(z_matrix ),pointer::pmatrix integer,intent(out)::istat type(z_element ),pointer ::element_tester istat=-1 element_tester=>pmatrix% z_element_start do while((element_tester%number.ne.nmb_element)& .and.(associated(element_tester%pntr))) element_tester => element_tester%pntr end do if (element_tester%number.eq.nmb_element) then pelement => element_tester%contents istat = 0 return else nullify(pelement) istat = blas_error_param return end if end subroutine zaccess_element !* subroutine z_element_num (nmb_element,pmatrix,i,j,istat) implicit none integer,intent(out),target::nmb_element type(z_matrix ),pointer::pmatrix integer ,intent(in)::i,j integer,intent(out)::istat type(z_element ),pointer ::element_tester logical:: finder istat = -1 select case(pmatrix%format) case('normal') element_tester=>pmatrix% z_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%pntin%row_ind.eq.i)& .and.(element_tester%contents%pntin%col_ind.eq.j)) then nmb_element=element_tester%number else nmb_element=0 end if end if case('block') element_tester=>pmatrix% z_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr))& .and.(.not.finder)) if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%blin%row_block_ind.eq.i)& .and.(element_tester%contents%blin%col_block_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case('vblock') element_tester=>pmatrix% z_element_start if(.not.associated( element_tester%pntr)) then if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if else finder=.false. do while((associated(element_tester%pntr)).and.& (.not.finder)) if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then finder=.true. else element_tester => element_tester%pntr end if end do if((element_tester%contents%vblin%row_vblock_ind.eq.i)& .and.(element_tester%contents%vblin%col_vblock_ind.eq.j))then nmb_element=element_tester%number else nmb_element=0 end if end if case default istat = blas_error_param return end select istat = 0 end subroutine z_element_num !* subroutine z_dealloc (nmb,istat) implicit none integer,intent(in)::nmb integer,intent(out)::istat type(z_matrix ),pointer::pmatrix type(z_element ),pointer ::element_tester,next_element istat = -1 call zaccess_matrix (pmatrix,nmb,istat) if (istat.ne.0) return element_tester=>pmatrix% z_element_start if(.not.associated(element_tester%pntr)) then call dealloc_z_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return else next_element=>element_tester%pntr do while((associated(next_element))) call dealloc_z_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return element_tester=>next_element next_element=>element_tester%pntr end do call dealloc_z_element (element_tester%number,& pmatrix,istat) if (istat.ne.0) return end if call dealloc_z_matrix (nmb,istat) if (istat.ne.0) return istat = 0 return end subroutine z_dealloc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_INSERTING SHAR_EOF fi # end of overwriting check if test -f 'INS_ROUTINER.f90' then echo shar: will not over-write existing file "'INS_ROUTINER.f90'" else cat << "SHAR_EOF" > 'INS_ROUTINER.f90' module mod_INS_ROUTINER use mod_INSERTING use SparseBLAS1 use properties interface INS_entry module procedure iINS_entry module procedure sINS_entry module procedure dINS_entry module procedure cINS_entry module procedure zINS_entry end interface interface INS_block module procedure iINS_block module procedure sINS_block module procedure dINS_block module procedure cINS_block module procedure zINS_block end interface interface INS_bl_entr module procedure iINS_bl_entr module procedure sINS_bl_entr module procedure dINS_bl_entr module procedure cINS_bl_entr module procedure zINS_bl_entr end interface interface INS_varblock module procedure iINS_varblock module procedure sINS_varblock module procedure dINS_varblock module procedure cINS_varblock module procedure zINS_varblock end interface interface INS_varbl_entr module procedure iINS_varbl_entr module procedure sINS_varbl_entr module procedure dINS_varbl_entr module procedure cINS_varbl_entr module procedure zINS_varbl_entr end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine iINS_entry (pmatrix,val,i,j,istat) implicit none type(i_matrix ),pointer ::pmatrix integer ,intent(in) ::val integer ,intent(in) ::i,j integer, intent(out) :: istat type(i_inelement ),pointer ::pelement integer::nmb_element,ind istat=-1 if((i.gt.pmatrix%DIM(1)).or.& (j.gt.pmatrix%DIM(2))) then istat = blas_error_param return else call new_i_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call i_element_num (ind,pmatrix,i,j,istat) if (istat.ne.0) return if(ind.eq.0) then call access_element(pelement,nmb_element,& pmatrix,istat) if (istat.ne.0) return pelement%pntin%value=val pelement%pntin%row_ind=i pelement%pntin%col_ind=j else call access_element(pelement,ind,pmatrix,istat) if (istat.ne.0) return pelement%pntin%value= pelement%pntin%value+val call dealloc_i_element (nmb_element,pmatrix,istat) if (istat.ne.0) return end if end if end subroutine iINS_entry !* subroutine iINS_block (pmatrix,val,i,j,istat) implicit none type( i_matrix ),pointer ::pmatrix integer ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind,ierr integer ,dimension(:,:),allocatable,target::vv type(i_inelement ),pointer::pelement integer ::s_rows,s_cols istat = -1 s_rows=size(val,1) s_cols=size(val,2) allocate(vv(s_rows,s_cols),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif if((i.gt.pmatrix%DIM(3).or.(j.gt.pmatrix%DIM(4))& .or.(s_rows.ne.pmatrix%DIM(5)& .or.(s_cols.ne.pmatrix%DIM(6))))) then istat = blas_error_param return else call new_i_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call i_element_num (ind,pmatrix,i,j,istat) if (istat.ne.0) return if(ind.eq.0) then call access_element(pelement,nmb_element,& pmatrix,istat) if (istat.ne.0) return allocate(pelement%blin%value(s_rows,s_cols),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif pelement%blin%value=val pelement%blin%row_block_ind=i pelement%blin%col_block_ind=j else call access_element(pelement,ind,pmatrix,istat) if (istat.ne.0) return vv=vv+val pelement%blin%value=pelement%blin%value+val call dealloc_i_element (nmb_element,pmatrix,istat) if (istat.ne.0) return end if end if deallocate(vv,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine iINS_block !* subroutine iINS_bl_entr (pmatrix,val,i,j,istat) implicit none type(i_matrix ),pointer ::pmatrix integer ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat integer ,dimension(:,:),allocatable,target ::vall integer::ii,jj,ierr istat = -1 ii=floor(real((i-1)/(pmatrix%DIM(5)))) jj=floor(real((j-1)/(pmatrix%DIM(6)))) allocate(vall(pmatrix%DIM(5),pmatrix%DIM(6)),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif vall= 0 vall(i-ii*pmatrix%DIM(5),j-jj*pmatrix%DIM(6))=val call iINS_block (pmatrix,vall,ii+1,jj+1,istat) if (istat.ne.0) return deallocate(vall,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine iINS_bl_entr !* subroutine iINS_varblock (vpmatrix,val,i,j,istat) implicit none type(i_matrix ),pointer ::vpmatrix integer ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind integer::ierr integer ,dimension(:,:),allocatable,target::vv type(i_inelement ),pointer::pelement integer ::s_rows,s_cols,k istat = -1 s_rows=size(val,1) s_cols=size(val,2) allocate(vv(s_rows,s_cols),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif if((i.gt.vpmatrix%DIM(3).or.j.gt.vpmatrix%DIM(4))& .or.(s_rows.ne.vpmatrix%sub_rows(i))& .or.(s_cols.ne.vpmatrix%sub_cols(j))) then istat = blas_error_param return else call new_i_element (vpmatrix,nmb_element,istat) if (istat.ne.0) return call i_element_num (ind,vpmatrix,i,j,istat) if (istat.ne.0) return if(ind.eq.0) then call access_element(pelement,nmb_element,& vpmatrix,istat) if (istat.ne.0) return allocate(pelement%vblin%value(vpmatrix%sub_rows(i),& vpmatrix%sub_cols(j)),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif pelement%vblin%value=val pelement%vblin%row_vblock_ind=i pelement%vblin%col_vblock_ind=j do k=i+1,vpmatrix%DIM(3) vpmatrix%trb(k)=vpmatrix%trb(k)+1 end do do k=1,vpmatrix%DIM(3)-1 vpmatrix%tre(k)=vpmatrix%trb(k+1) end do vpmatrix%tre(vpmatrix%DIM(3))=nmb_element+1 else call access_element(pelement,ind,vpmatrix,istat) if (istat.ne.0) return pelement%vblin%value= pelement%vblin%value+val call dealloc_i_element (nmb_element,vpmatrix,istat) if (istat.ne.0) return end if end if istat = 0 return end subroutine iINS_varblock !* subroutine iINS_varbl_entr (vpmatrix,val,i,j,istat) implicit none type(i_matrix ),pointer ::vpmatrix integer ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat integer ,dimension(:,:),allocatable ::vall integer::ii,jj,k,p,ind1,ind2,vall_ind1,vall_ind2,ierr ! determine the row of block entring ind1=0 do k=1,vpmatrix%DIM(3) ind1=ind1+vpmatrix%sub_rows(k) if(ind1.ge.i) exit end do if(k.le.vpmatrix%DIM(3)) then ii=k vall_ind1=i-(ind1-vpmatrix%sub_rows(k)) else istat = blas_error_param return end if ! determine the col of block entring ind2=0 do p=1,vpmatrix%DIM(3) ind2=ind2+vpmatrix%sub_cols(p) if(ind2.ge.j) exit end do if(p.le.vpmatrix%DIM(4)) then jj=p vall_ind2=j-(ind2-vpmatrix%sub_cols(p)) else istat = blas_error_param return end if allocate(vall(vpmatrix%sub_rows(ii),& vpmatrix%sub_cols(jj)),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif vall= 0 vall(vall_ind1,vall_ind2)=val call iINS_varblock (vpmatrix,vall,ii,jj,istat) if (istat.ne.0) return deallocate(vall,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine iINS_varbl_entr !* subroutine iuscr_varend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,ierr,ind,kb,mb integer, dimension(:),allocatable :: bindx,indx,rpntr,& cpntr,bpntrb,bpntre integer , dimension(:),allocatable :: val integer :: size_val,val_ind,indx_ind,bindx_ind,ii,jj,i,j type(i_matrix ),pointer::pmatrix type(i_inelement ),pointer::pelement istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return mb=pmatrix%DIM(3) kb=pmatrix%DIM(4) ! determine size of val,m,n size_val=0 m=0 n=0 do i=1,pmatrix%DIM(3) do j=1,pmatrix%DIM(4) call i_element_num (ind,pmatrix,i,j,ierr) if(ind.ne.0) then call access_element(pelement,ind,pmatrix,istat) if (istat.ne.0) return size_val=size_val+& pmatrix%sub_rows(i)*pmatrix%sub_cols(j) end if end do end do do i=1,pmatrix%DIM(3) m=m+pmatrix%sub_rows(i) end do do j=1,pmatrix%DIM(4) n=n+pmatrix%sub_cols(j) end do allocate(val(size_val),& indx(pmatrix% i_element_start %number+1),& bindx(pmatrix% i_element_start %number),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif val= 0 ! fill val ,indx and bindx val_ind=0 indx_ind=1 bindx_ind=0 indx(1)=1 do i=1,pmatrix%DIM(3) do j=1,pmatrix%DIM(4) call i_element_num (ind,pmatrix,i,j,istat) if (istat.ne.0) return if(ind.ne.0) then call access_element(pelement,ind,pmatrix,istat) if (istat.ne.0) return do jj=1,pmatrix%sub_cols(j) do ii=1,pmatrix%sub_rows(i) val_ind=val_ind+1 val(val_ind)=pelement%vblin%value(ii,jj) end do end do bindx_ind=bindx_ind+1 bindx(bindx_ind)=j indx_ind=indx_ind+1 indx(indx_ind)=indx(indx_ind-1)& +pmatrix%sub_rows(i)*pmatrix%sub_cols(j) end if end do end do ! fill rpntr, cpntr,bpntrb,bpntre allocate(rpntr(pmatrix%DIM(3)+1),& cpntr(pmatrix%DIM(4)+1),& bpntrb(pmatrix%DIM(3)),& bpntre(pmatrix%DIM(3)),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif rpntr(1)=1 do i=2,pmatrix%DIM(3)+1 rpntr(i)= rpntr(i-1)+pmatrix%sub_rows(i-1) end do cpntr(1)=1 do j=2,pmatrix%DIM(4)+1 cpntr(j)= cpntr(j-1)+pmatrix%sub_cols(j-1) end do do i=1,pmatrix%DIM(3) bpntrb(i)=pmatrix%trb(i) bpntre(i)=pmatrix%tre(i) end do ! RELEASING call i_dealloc (a,istat) if (istat.ne.0) return ! CREATING MATRIX IN VBR FORMAT istat=-1 !needed to create copy of data call iuscr_vbr (m,n,val,indx,bindx,rpntr,cpntr,& bpntrb,bpntre,mb,kb,prpty,istat,a) if (istat.ne.0) return deallocate(val,bindx,indx,rpntr, & cpntr,bpntrb,bpntre,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine iuscr_varend !* subroutine iuscr_normend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,nnz integer, dimension(:),allocatable :: indx,jndx integer , dimension(:),allocatable :: val integer :: nmb_element,i,ierr type(i_matrix ),pointer::pmatrix type(i_inelement ),pointer::pelement call access_matrix(pmatrix,a,istat) if (istat.ne.0) return m=pmatrix%DIM(1) !nb_of_rows n=pmatrix%DIM(2) !nb_of_cols nnz=pmatrix% i_element_start %number allocate(val(nnz),indx(nnz),jndx(nnz),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif nmb_element=nnz+1 do i=1,nnz call access_element(pelement,nmb_element-i,& pmatrix,istat) if (istat.ne.0) return val(i)=pelement%pntin%value indx(i)=pelement%pntin%row_ind jndx(i)=pelement%pntin%col_ind end do call i_dealloc (a,istat) if (istat.ne.0) return ! CREATING A MATRIX IN COO FORMAT istat=-1 !needed to create copy of data call iuscr_coo (m,n,val,indx,jndx,nnz,prpty,istat,a) if (istat.ne.0) return deallocate(val,indx,jndx,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine iuscr_normend !* subroutine iuscr_blockend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,bnnz,ierr,ind,kb,lb,dummy,k,mb,i,j integer, dimension(:),allocatable :: bindx,bjndx integer , dimension(:),allocatable :: val integer :: nmb_block type(i_matrix ),pointer::pmatrix type(i_inelement ),pointer::pelement istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return lb=pmatrix%DIM(5) bnnz=pmatrix% i_element_start %number mb=pmatrix%DIM(3) kb=pmatrix%DIM(4) m=mb*lb n=kb*lb ind=0 dummy=bnnz*lb*lb allocate(val(dummy),bindx(bnnz),bjndx(bnnz),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif nmb_block=bnnz+1 do i=1,bnnz k=1 call access_element(pelement,nmb_block-i,pmatrix,& istat) if (istat.ne.0) return do j=1,lb do k=1,lb ind=ind+1 val(ind)=pelement%blin%value(k,j) end do end do bindx(i)=pelement%blin%row_block_ind bjndx(i)=pelement%blin%col_block_ind end do ! RELEASING call i_dealloc (a,istat) if (istat.ne.0) return ! CREATE A MATRIX IN BCO FORMAT istat=-1 !needed to create copy of data call iuscr_bco (m,n,val,bindx,bjndx,bnnz,& mb,kb,lb,prpty,istat,a) if (istat.ne.0) return deallocate(val,bindx,bjndx,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine iuscr_blockend ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine sINS_entry (pmatrix,val,i,j,istat) implicit none type(s_matrix ),pointer ::pmatrix real(KIND=sp) ,intent(in) ::val integer ,intent(in) ::i,j integer, intent(out) :: istat type(s_inelement ),pointer ::pelement integer::nmb_element,ind istat=-1 if((i.gt.pmatrix%DIM(1)).or.& (j.gt.pmatrix%DIM(2))) then istat = blas_error_param return else call new_s_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call s_element_num (ind,pmatrix,i,j,istat) if (istat.ne.0) return if(ind.eq.0) then call access_element(pelement,nmb_element,& pmatrix,istat) if (istat.ne.0) return pelement%pntin%value=val pelement%pntin%row_ind=i pelement%pntin%col_ind=j else call access_element(pelement,ind,pmatrix,istat) if (istat.ne.0) return pelement%pntin%value= pelement%pntin%value+val call dealloc_s_element (nmb_element,pmatrix,istat) if (istat.ne.0) return end if end if end subroutine sINS_entry !* subroutine sINS_block (pmatrix,val,i,j,istat) implicit none type( s_matrix ),pointer ::pmatrix real(KIND=sp) ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind,ierr real(KIND=sp) ,dimension(:,:),allocatable,target::vv type(s_inelement ),pointer::pelement integer ::s_rows,s_cols istat = -1 s_rows=size(val,1) s_cols=size(val,2) allocate(vv(s_rows,s_cols),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif if((i.gt.pmatrix%DIM(3).or.(j.gt.pmatrix%DIM(4))& .or.(s_rows.ne.pmatrix%DIM(5)& .or.(s_cols.ne.pmatrix%DIM(6))))) then istat = blas_error_param return else call new_s_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call s_element_num (ind,pmatrix,i,j,istat) if (istat.ne.0) return if(ind.eq.0) then call access_element(pelement,nmb_element,& pmatrix,istat) if (istat.ne.0) return allocate(pelement%blin%value(s_rows,s_cols),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif pelement%blin%value=val pelement%blin%row_block_ind=i pelement%blin%col_block_ind=j else call access_element(pelement,ind,pmatrix,istat) if (istat.ne.0) return vv=vv+val pelement%blin%value=pelement%blin%value+val call dealloc_s_element (nmb_element,pmatrix,istat) if (istat.ne.0) return end if end if deallocate(vv,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine sINS_block !* subroutine sINS_bl_entr (pmatrix,val,i,j,istat) implicit none type(s_matrix ),pointer ::pmatrix real(KIND=sp) ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat real(KIND=sp) ,dimension(:,:),allocatable,target ::vall integer::ii,jj,ierr istat = -1 ii=floor(real((i-1)/(pmatrix%DIM(5)))) jj=floor(real((j-1)/(pmatrix%DIM(6)))) allocate(vall(pmatrix%DIM(5),pmatrix%DIM(6)),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif vall= 0.0e0 vall(i-ii*pmatrix%DIM(5),j-jj*pmatrix%DIM(6))=val call sINS_block (pmatrix,vall,ii+1,jj+1,istat) if (istat.ne.0) return deallocate(vall,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine sINS_bl_entr !* subroutine sINS_varblock (vpmatrix,val,i,j,istat) implicit none type(s_matrix ),pointer ::vpmatrix real(KIND=sp) ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind integer::ierr real(KIND=sp) ,dimension(:,:),allocatable,target::vv type(s_inelement ),pointer::pelement integer ::s_rows,s_cols,k istat = -1 s_rows=size(val,1) s_cols=size(val,2) allocate(vv(s_rows,s_cols),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif if((i.gt.vpmatrix%DIM(3).or.j.gt.vpmatrix%DIM(4))& .or.(s_rows.ne.vpmatrix%sub_rows(i))& .or.(s_cols.ne.vpmatrix%sub_cols(j))) then istat = blas_error_param return else call new_s_element (vpmatrix,nmb_element,istat) if (istat.ne.0) return call s_element_num (ind,vpmatrix,i,j,istat) if (istat.ne.0) return if(ind.eq.0) then call access_element(pelement,nmb_element,& vpmatrix,istat) if (istat.ne.0) return allocate(pelement%vblin%value(vpmatrix%sub_rows(i),& vpmatrix%sub_cols(j)),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif pelement%vblin%value=val pelement%vblin%row_vblock_ind=i pelement%vblin%col_vblock_ind=j do k=i+1,vpmatrix%DIM(3) vpmatrix%trb(k)=vpmatrix%trb(k)+1 end do do k=1,vpmatrix%DIM(3)-1 vpmatrix%tre(k)=vpmatrix%trb(k+1) end do vpmatrix%tre(vpmatrix%DIM(3))=nmb_element+1 else call access_element(pelement,ind,vpmatrix,istat) if (istat.ne.0) return pelement%vblin%value= pelement%vblin%value+val call dealloc_s_element (nmb_element,vpmatrix,istat) if (istat.ne.0) return end if end if istat = 0 return end subroutine sINS_varblock !* subroutine sINS_varbl_entr (vpmatrix,val,i,j,istat) implicit none type(s_matrix ),pointer ::vpmatrix real(KIND=sp) ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat real(KIND=sp) ,dimension(:,:),allocatable ::vall integer::ii,jj,k,p,ind1,ind2,vall_ind1,vall_ind2,ierr ! determine the row of block entring ind1=0 do k=1,vpmatrix%DIM(3) ind1=ind1+vpmatrix%sub_rows(k) if(ind1.ge.i) exit end do if(k.le.vpmatrix%DIM(3)) then ii=k vall_ind1=i-(ind1-vpmatrix%sub_rows(k)) else istat = blas_error_param return end if ! determine the col of block entring ind2=0 do p=1,vpmatrix%DIM(3) ind2=ind2+vpmatrix%sub_cols(p) if(ind2.ge.j) exit end do if(p.le.vpmatrix%DIM(4)) then jj=p vall_ind2=j-(ind2-vpmatrix%sub_cols(p)) else istat = blas_error_param return end if allocate(vall(vpmatrix%sub_rows(ii),& vpmatrix%sub_cols(jj)),STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif vall= 0.0e0 vall(vall_ind1,vall_ind2)=val call sINS_varblock (vpmatrix,vall,ii,jj,istat) if (istat.ne.0) return deallocate(vall,STAT=ierr) if(ierr.ne.0) then istat = blas_error_memdeloc return else istat = 0 endif end subroutine sINS_varbl_entr !* subroutine suscr_varend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,ierr,ind,kb,mb integer, dimension(:),allocatable :: bindx,indx,rpntr,& cpntr,bpntrb,bpntre real(KIND=sp) , dimension(:),allocatable :: val integer :: size_val,val_ind,indx_ind,bindx_ind,ii,jj,i,j type(s_matrix ),pointer::pmatrix type(s_inelement ),pointer::pelement istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return mb=pmatrix%DIM(3) kb=pmatrix%DIM(4) ! determine size of val,m,n size_val=0 m=0 n=0 do i=1,pmatrix%DIM(3) do j=1,pmatrix%DIM(4) call s_element_num (ind,pmatrix,i,j,ierr) if(ind.ne.0) then call access_element(pelement,ind,pmatrix,istat) if (istat.ne.0) return size_val=size_val+& pmatrix%sub_rows(i)*pmatrix%sub_cols(j) end if end do end do do i=1,pmatrix%DIM(3) m=m+pmatrix%sub_rows(i) end do do j=1,pmatrix%DIM(4) n=n+pmatrix%sub_cols(j) end do allocate(val(size_val),& indx(pmatrix% s_element_start %number+1),& bindx(pmatrix% s_element_start %number),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif val= 0.0e0 ! fill val ,indx and bindx val_ind=0 indx_ind=1 bindx_ind=0 indx(1)=1 do i=1,pmatrix%DIM(3) do j=1,pmatrix%DIM(4) call s_element_num (ind,pmatrix,i,j,istat) if (istat.ne.0) return if(ind.ne.0) then call access_element(pelement,ind,pmatrix,istat) if (istat.ne.0) return do jj=1,pmatrix%sub_cols(j) do ii=1,pmatrix%sub_rows(i) val_ind=val_ind+1 val(val_ind)=pelement%vblin%value(ii,jj) end do end do bindx_ind=bindx_ind+1 bindx(bindx_ind)=j indx_ind=indx_ind+1 indx(indx_ind)=indx(indx_ind-1)& +pmatrix%sub_rows(i)*pmatrix%sub_cols(j) end if end do end do ! fill rpntr, cpntr,bpntrb,bpntre allocate(rpntr(pmatrix%DIM(3)+1),& cpntr(pmatrix%DIM(4)+1),& bpntrb(pmatrix%DIM(3)),& bpntre(pmatrix%DIM(3)),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif rpntr(1)=1 do i=2,pmatrix%DIM(3)+1 rpntr(i)= rpntr(i-1)+pmatrix%sub_rows(i-1) end do cpntr(1)=1 do j=2,pmatrix%DIM(4)+1 cpntr(j)= cpntr(j-1)+pmatrix%sub_cols(j-1) end do do i=1,pmatrix%DIM(3) bpntrb(i)=pmatrix%trb(i) bpntre(i)=pmatrix%tre(i) end do ! RELEASING call s_dealloc (a,istat) if (istat.ne.0) return ! CREATING MATRIX IN VBR F