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 FORMAT istat=-1 !needed to create copy of data call suscr_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 suscr_varend !* subroutine suscr_normend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,nnz integer, dimension(:),allocatable :: indx,jndx real(KIND=sp) , dimension(:),allocatable :: val integer :: nmb_element,i,ierr type(s_matrix ),pointer::pmatrix type(s_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% s_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 s_dealloc (a,istat) if (istat.ne.0) return ! CREATING A MATRIX IN COO FORMAT istat=-1 !needed to create copy of data call suscr_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 suscr_normend !* subroutine suscr_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 real(KIND=sp) , dimension(:),allocatable :: val integer :: nmb_block type(s_matrix ),pointer::pmatrix type(s_inelement ),pointer::pelement istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return lb=pmatrix%DIM(5) bnnz=pmatrix% s_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 s_dealloc (a,istat) if (istat.ne.0) return ! CREATE A MATRIX IN BCO FORMAT istat=-1 !needed to create copy of data call suscr_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 suscr_blockend ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine dINS_entry (pmatrix,val,i,j,istat) implicit none type(d_matrix ),pointer ::pmatrix real(KIND=dp) ,intent(in) ::val integer ,intent(in) ::i,j integer, intent(out) :: istat type(d_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_d_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call d_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_d_element (nmb_element,pmatrix,istat) if (istat.ne.0) return end if end if end subroutine dINS_entry !* subroutine dINS_block (pmatrix,val,i,j,istat) implicit none type( d_matrix ),pointer ::pmatrix real(KIND=dp) ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind,ierr real(KIND=dp) ,dimension(:,:),allocatable,target::vv type(d_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_d_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call d_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_d_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 dINS_block !* subroutine dINS_bl_entr (pmatrix,val,i,j,istat) implicit none type(d_matrix ),pointer ::pmatrix real(KIND=dp) ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat real(KIND=dp) ,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.0d0 vall(i-ii*pmatrix%DIM(5),j-jj*pmatrix%DIM(6))=val call dINS_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 dINS_bl_entr !* subroutine dINS_varblock (vpmatrix,val,i,j,istat) implicit none type(d_matrix ),pointer ::vpmatrix real(KIND=dp) ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind integer::ierr real(KIND=dp) ,dimension(:,:),allocatable,target::vv type(d_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_d_element (vpmatrix,nmb_element,istat) if (istat.ne.0) return call d_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_d_element (nmb_element,vpmatrix,istat) if (istat.ne.0) return end if end if istat = 0 return end subroutine dINS_varblock !* subroutine dINS_varbl_entr (vpmatrix,val,i,j,istat) implicit none type(d_matrix ),pointer ::vpmatrix real(KIND=dp) ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat real(KIND=dp) ,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.0d0 vall(vall_ind1,vall_ind2)=val call dINS_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 dINS_varbl_entr !* subroutine duscr_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=dp) , dimension(:),allocatable :: val integer :: size_val,val_ind,indx_ind,bindx_ind,ii,jj,i,j type(d_matrix ),pointer::pmatrix type(d_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 d_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% d_element_start %number+1),& bindx(pmatrix% d_element_start %number),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif val= 0.0d0 ! 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 d_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 d_dealloc (a,istat) if (istat.ne.0) return ! CREATING MATRIX IN VBR FORMAT istat=-1 !needed to create copy of data call duscr_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 duscr_varend !* subroutine duscr_normend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,nnz integer, dimension(:),allocatable :: indx,jndx real(KIND=dp) , dimension(:),allocatable :: val integer :: nmb_element,i,ierr type(d_matrix ),pointer::pmatrix type(d_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% d_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 d_dealloc (a,istat) if (istat.ne.0) return ! CREATING A MATRIX IN COO FORMAT istat=-1 !needed to create copy of data call duscr_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 duscr_normend !* subroutine duscr_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 real(KIND=dp) , dimension(:),allocatable :: val integer :: nmb_block type(d_matrix ),pointer::pmatrix type(d_inelement ),pointer::pelement istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return lb=pmatrix%DIM(5) bnnz=pmatrix% d_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 d_dealloc (a,istat) if (istat.ne.0) return ! CREATE A MATRIX IN BCO FORMAT istat=-1 !needed to create copy of data call duscr_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 duscr_blockend ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine cINS_entry (pmatrix,val,i,j,istat) implicit none type(c_matrix ),pointer ::pmatrix complex(KIND=sp) ,intent(in) ::val integer ,intent(in) ::i,j integer, intent(out) :: istat type(c_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_c_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call c_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_c_element (nmb_element,pmatrix,istat) if (istat.ne.0) return end if end if end subroutine cINS_entry !* subroutine cINS_block (pmatrix,val,i,j,istat) implicit none type( c_matrix ),pointer ::pmatrix complex(KIND=sp) ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind,ierr complex(KIND=sp) ,dimension(:,:),allocatable,target::vv type(c_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_c_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call c_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_c_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 cINS_block !* subroutine cINS_bl_entr (pmatrix,val,i,j,istat) implicit none type(c_matrix ),pointer ::pmatrix complex(KIND=sp) ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat complex(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, 0.0e0) vall(i-ii*pmatrix%DIM(5),j-jj*pmatrix%DIM(6))=val call cINS_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 cINS_bl_entr !* subroutine cINS_varblock (vpmatrix,val,i,j,istat) implicit none type(c_matrix ),pointer ::vpmatrix complex(KIND=sp) ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind integer::ierr complex(KIND=sp) ,dimension(:,:),allocatable,target::vv type(c_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_c_element (vpmatrix,nmb_element,istat) if (istat.ne.0) return call c_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_c_element (nmb_element,vpmatrix,istat) if (istat.ne.0) return end if end if istat = 0 return end subroutine cINS_varblock !* subroutine cINS_varbl_entr (vpmatrix,val,i,j,istat) implicit none type(c_matrix ),pointer ::vpmatrix complex(KIND=sp) ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat complex(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, 0.0e0) vall(vall_ind1,vall_ind2)=val call cINS_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 cINS_varbl_entr !* subroutine cuscr_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 complex(KIND=sp) , dimension(:),allocatable :: val integer :: size_val,val_ind,indx_ind,bindx_ind,ii,jj,i,j type(c_matrix ),pointer::pmatrix type(c_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 c_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% c_element_start %number+1),& bindx(pmatrix% c_element_start %number),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif val= (0.0e0, 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 c_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 c_dealloc (a,istat) if (istat.ne.0) return ! CREATING MATRIX IN VBR FORMAT istat=-1 !needed to create copy of data call cuscr_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 cuscr_varend !* subroutine cuscr_normend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,nnz integer, dimension(:),allocatable :: indx,jndx complex(KIND=sp) , dimension(:),allocatable :: val integer :: nmb_element,i,ierr type(c_matrix ),pointer::pmatrix type(c_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% c_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 c_dealloc (a,istat) if (istat.ne.0) return ! CREATING A MATRIX IN COO FORMAT istat=-1 !needed to create copy of data call cuscr_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 cuscr_normend !* subroutine cuscr_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 complex(KIND=sp) , dimension(:),allocatable :: val integer :: nmb_block type(c_matrix ),pointer::pmatrix type(c_inelement ),pointer::pelement istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return lb=pmatrix%DIM(5) bnnz=pmatrix% c_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 c_dealloc (a,istat) if (istat.ne.0) return ! CREATE A MATRIX IN BCO FORMAT istat=-1 !needed to create copy of data call cuscr_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 cuscr_blockend ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine zINS_entry (pmatrix,val,i,j,istat) implicit none type(z_matrix ),pointer ::pmatrix complex(KIND=dp) ,intent(in) ::val integer ,intent(in) ::i,j integer, intent(out) :: istat type(z_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_z_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call z_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_z_element (nmb_element,pmatrix,istat) if (istat.ne.0) return end if end if end subroutine zINS_entry !* subroutine zINS_block (pmatrix,val,i,j,istat) implicit none type( z_matrix ),pointer ::pmatrix complex(KIND=dp) ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind,ierr complex(KIND=dp) ,dimension(:,:),allocatable,target::vv type(z_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_z_element (pmatrix,nmb_element,istat) if (istat.ne.0) return call z_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_z_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 zINS_block !* subroutine zINS_bl_entr (pmatrix,val,i,j,istat) implicit none type(z_matrix ),pointer ::pmatrix complex(KIND=dp) ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat complex(KIND=dp) ,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.0d0, 0.0d0) vall(i-ii*pmatrix%DIM(5),j-jj*pmatrix%DIM(6))=val call zINS_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 zINS_bl_entr !* subroutine zINS_varblock (vpmatrix,val,i,j,istat) implicit none type(z_matrix ),pointer ::vpmatrix complex(KIND=dp) ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind integer::ierr complex(KIND=dp) ,dimension(:,:),allocatable,target::vv type(z_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_z_element (vpmatrix,nmb_element,istat) if (istat.ne.0) return call z_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_z_element (nmb_element,vpmatrix,istat) if (istat.ne.0) return end if end if istat = 0 return end subroutine zINS_varblock !* subroutine zINS_varbl_entr (vpmatrix,val,i,j,istat) implicit none type(z_matrix ),pointer ::vpmatrix complex(KIND=dp) ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat complex(KIND=dp) ,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.0d0, 0.0d0) vall(vall_ind1,vall_ind2)=val call zINS_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 zINS_varbl_entr !* subroutine zuscr_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 complex(KIND=dp) , dimension(:),allocatable :: val integer :: size_val,val_ind,indx_ind,bindx_ind,ii,jj,i,j type(z_matrix ),pointer::pmatrix type(z_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 z_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% z_element_start %number+1),& bindx(pmatrix% z_element_start %number),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif val= (0.0d0, 0.0d0) ! 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 z_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 z_dealloc (a,istat) if (istat.ne.0) return ! CREATING MATRIX IN VBR FORMAT istat=-1 !needed to create copy of data call zuscr_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 zuscr_varend !* subroutine zuscr_normend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,nnz integer, dimension(:),allocatable :: indx,jndx complex(KIND=dp) , dimension(:),allocatable :: val integer :: nmb_element,i,ierr type(z_matrix ),pointer::pmatrix type(z_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% z_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 z_dealloc (a,istat) if (istat.ne.0) return ! CREATING A MATRIX IN COO FORMAT istat=-1 !needed to create copy of data call zuscr_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 zuscr_normend !* subroutine zuscr_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 complex(KIND=dp) , dimension(:),allocatable :: val integer :: nmb_block type(z_matrix ),pointer::pmatrix type(z_inelement ),pointer::pelement istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return lb=pmatrix%DIM(5) bnnz=pmatrix% z_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 z_dealloc (a,istat) if (istat.ne.0) return ! CREATE A MATRIX IN BCO FORMAT istat=-1 !needed to create copy of data call zuscr_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 zuscr_blockend ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_INS_ROUTINER SHAR_EOF fi # end of overwriting check if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << "SHAR_EOF" > 'Makefile' # FFLAGS = -g CFLAFS = # LDFLAGS = # FC = f90 CC = cc LD = $(FC) AR = ar -r -v RANLIB = RM = rm -f # MOD_SUF = mod ############################################################################### OBJS = conv_tools.o dense.o hash.o info.o link.o\ lmbv_coo.o lmbv_csc.o lmbv_csr.o lmbv_dia.o\ lmbv_bco.o lmbv_bsc.o lmbv_bsr.o lmbv_bdi.o lmbv_vbr.o\ lsbv_coo.o lsbv_csc.o lsbv_csr.o lsbv_dia.o\ lsbv_bco.o lsbv_bsc.o lsbv_bsr.o lsbv_bdi.o lsbv_vbr.o\ mbv.o blas_sparse_namedconstants.o properties.o\ rmbv_coo.o rmbv_csc.o rmbv_csr.o rmbv_dia.o\ rmbv_bco.o rmbv_bsc.o rmbv_bsr.o rmbv_bdi.o rmbv_vbr.o\ rsbv_coo.o rsbv_csc.o rsbv_csr.o rsbv_dia.o\ rsbv_bco.o rsbv_bsc.o rsbv_bsr.o rsbv_bdi.o rsbv_vbr.o\ sbv.o types.o\ usconv_coo2csr.o usconv_csr2coo.o usconv_csc2coo.o usconv_coo2csc.o\ usconv_coo2dia.o usconv_dia2coo.o usconv_bco2bsr.o usconv_bco2bsc.o\ usconv_bsr2bco.o usconv_bsc2bco.o usconv_bco2bdi.o usconv_bdi2bco.o\ uscr_coo.o uscr_csc.o uscr_csr.o uscr_dia.o \ uscr_bco.o uscr_bsc.o uscr_bsr.o uscr_bdi.o uscr_vbr.o\ uscr_begin.o uscr_block_begin.o uscr_variable_block_begin.o\ ussp.o usgp.o\ uscr.o usds.o usmv.o usmm.o ussv.o ussm.o\ usdot.o usaxpy.o usga.o usgz.o ussc.o\ SparseBLAS.o SparseBLAS1.o\ Entry.o INS_ROUTINER.o INSERTING.o uscr_insert_block.o\ uscr_insert_col.o uscr_insert_row.o uscr_insert_entries.o\ uscr_insert_clique.o uscr_insert_entry.o uscr_end.o\ blas_sparse_proto.o blas_sparse.o COBJS = LIBS = ############################################################################### libSparseBLAS_$(SBLAS_ARCH).a:$(OBJS) $(AR) $@ $(OBJS) ############################################################################### blas_sparse.o : blas_sparse_namedconstants.o blas_sparse_proto.o blas_sparse_proto.o: SparseBLAS1.o Entry.o conv_tools.o : blas_sparse_namedconstants.o dense.o : properties.o Entry.o: uscr_begin.o uscr_insert_entry.o uscr_insert_col.o uscr_insert_row.o uscr_insert_entries.o uscr_end.o uscr_block_begin.o uscr_insert_block.o uscr_variable_block_begin.o uscr_insert_clique.o INS_ROUTINER.o INSERTING.o ussp.o usgp.o hash.o : blas_sparse_namedconstants.o info.o : link.o properties.o types.o INS_ROUTINER.o: INSERTING.o SparseBLAS1.o properties.o INSERTING.o : properties.o blas_sparse_namedconstants.o link.o : properties.o types.o mbv.o : lmbv_coo.o rmbv_coo.o lmbv_csc.o rmbv_csc.o lmbv_csr.o rmbv_csr.o\ lmbv_dia.o rmbv_dia.o rmbv_bsr.o lmbv_bsr.o lmbv_bsc.o rmbv_bsc.o\ lmbv_bdi.o rmbv_bdi.o lmbv_vbr.o rmbv_vbr.o lmbv_bco.o rmbv_bco.o lmbv_coo.o : properties.o link.o rmbv_coo.o : properties.o link.o lmbv_csc.o : properties.o link.o rmbv_csc.o : properties.o link.o lmbv_csr.o : properties.o link.o rmbv_csr.o : properties.o link.o lmbv_dia.o : properties.o link.o rmbv_dia.o : properties.o link.o lmbv_bco.o : properties.o link.o dense.o rmbv_bco.o : properties.o link.o dense.o lmbv_bsr.o : properties.o link.o dense.o rmbv_bsr.o : properties.o link.o dense.o lmbv_bsc.o : properties.o link.o dense.o rmbv_bsc.o : properties.o link.o dense.o lmbv_bdi.o : properties.o link.o dense.o rmbv_bdi.o : properties.o link.o dense.o lmbv_vbr.o : properties.o link.o dense.o rmbv_vbr.o : properties.o link.o dense.o lsbv_coo.o : properties.o link.o hash.o rsbv_coo.o : properties.o link.o hash.o lsbv_csc.o : properties.o link.o rsbv_csc.o : properties.o link.o lsbv_csr.o : properties.o link.o rsbv_csr.o : properties.o link.o lsbv_dia.o : properties.o link.o rsbv_dia.o : properties.o link.o lsbv_bco.o : properties.o link.o hash.o dense.o rsbv_bco.o : properties.o link.o hash.o dense.o lsbv_bsr.o : properties.o link.o dense.o rsbv_bsr.o : properties.o link.o dense.o lsbv_bsc.o : properties.o link.o dense.o rsbv_bsc.o : properties.o link.o dense.o lsbv_bdi.o : properties.o link.o dense.o rsbv_bdi.o : properties.o link.o dense.o lsbv_vbr.o : properties.o link.o dense.o rsbv_vbr.o : properties.o link.o dense.o properties.o : blas_sparse_namedconstants.o sbv.o : lsbv_coo.o rsbv_coo.o lsbv_csc.o rsbv_csc.o lsbv_csr.o rsbv_csr.o\ lsbv_dia.o rsbv_dia.o lsbv_bsr.o rsbv_bsr.o lsbv_bsc.o rsbv_bsc.o\ lsbv_bdi.o rsbv_bdi.o lsbv_vbr.o rsbv_vbr.o lsbv_bco.o rsbv_bco.o SparseBLAS.o: uscr.o usds.o usmv.o ussv.o usmm.o ussm.o info.o SparseBLAS1.o: SparseBLAS.o usconv_coo2csr.o usconv_coo2csc.o usconv_csr2coo.o usconv_csc2coo.o usconv_coo2dia.o usconv_dia2coo.o usconv_bco2bsr.o usconv_bco2bsc.o usconv_bsr2bco.o usconv_bsc2bco.o usconv_bco2bdi.o usconv_bdi2bco.o usdot.o usaxpy.o usga.o usgz.o ussc.o properties.o types.o : blas_sparse_namedconstants.o usaxpy.o : blas_sparse_namedconstants.o usconv_coo2csr.o :conv_tools.o properties.o link.o usconv_coo2csc.o :conv_tools.o properties.o link.o usconv_csr2coo.o :conv_tools.o properties.o link.o usconv_csc2coo.o :conv_tools.o properties.o link.o usconv_coo2dia.o :conv_tools.o properties.o link.o usconv_dia2coo.o :conv_tools.o properties.o link.o usconv_bco2bsr.o :conv_tools.o properties.o link.o usconv_bco2bsc.o :conv_tools.o properties.o link.o usconv_bsr2bco.o :conv_tools.o properties.o link.o usconv_bsc2bco.o :conv_tools.o properties.o link.o usconv_bco2bdi.o :conv_tools.o properties.o link.o usconv_bdi2bco.o :conv_tools.o properties.o link.o uscr.o : uscr_coo.o uscr_csc.o uscr_csr.o uscr_dia.o\ uscr_bco.o uscr_bsc.o uscr_bsr.o uscr_bdi.o uscr_vbr.o uscr_coo.o : properties.o link.o usds.o uscr_csc.o : properties.o link.o usds.o uscr_csr.o : properties.o link.o usds.o uscr_dia.o : properties.o link.o usds.o uscr_bco.o : properties.o link.o usds.o uscr_bsr.o : properties.o link.o usds.o uscr_bsc.o : properties.o link.o usds.o uscr_bdi.o : properties.o link.o usds.o uscr_vbr.o : properties.o link.o usds.o uscr_end.o : INS_ROUTINER.o INSERTING.o properties.o uscr_begin.o: INSERTING.o properties.o blas_sparse_namedconstants.o uscr_insert_block.o: INS_ROUTINER.o INSERTING.o blas_sparse_namedconstants.o uscr_block_begin.o: INSERTING.o properties.o blas_sparse_namedconstants.o uscr_variable_block_begin.o:INSERTING.o properties.o blas_sparse_namedconstants.o uscr_insert_entry.o: INS_ROUTINER.o INSERTING.o blas_sparse_namedconstants.o uscr_insert_col.o : uscr_insert_entry.o blas_sparse_namedconstants.o uscr_insert_row.o : uscr_insert_entry.o blas_sparse_namedconstants.o uscr_insert_clique.o: uscr_insert_entry.o blas_sparse_namedconstants.o uscr_insert_entries.o: uscr_insert_entry.o blas_sparse_namedconstants.o usdot.o : blas_sparse_namedconstants.o usga.o : blas_sparse_namedconstants.o ussc.o : blas_sparse_namedconstants.o usgz.o : blas_sparse_namedconstants.o ussp.o:INSERTING.o properties.o usgp.o:INSERTING.o properties.o usds.o : link.o usmv.o : properties.o link.o mbv.o usmm.o : properties.o link.o mbv.o ussv.o : properties.o link.o sbv.o ussm.o : properties.o link.o sbv.o ############################################################################### .SUFFIXES: .o .F .c .f .f90 .f.o : $(FC) $(FFLAGS) -c $*.f .F.o : $(FC) $(FFLAGS) -c $*.F .f90.o : $(FC) $(FFLAGS) -c $*.f90 .c.o : $(CC) $(CFLAGS) -c $*.c clean : $(RM) *.o *.$(MOD_SUF) libSparseBLAS*.a SHAR_EOF fi # end of overwriting check if test -f 'SparseBLAS.f90' then echo shar: will not over-write existing file "'SparseBLAS.f90'" else cat << "SHAR_EOF" > 'SparseBLAS.f90' module SparseBLAS ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 29.2.00 ! ! Description : SparseBLAS functions ! ********************************************************************** use mod_info use mod_uscr use mod_usds use mod_usmv use mod_ussv use mod_usmm use mod_ussm end module SparseBLAS SHAR_EOF fi # end of overwriting check if test -f 'SparseBLAS1.f90' then echo shar: will not over-write existing file "'SparseBLAS1.f90'" else cat << "SHAR_EOF" > 'SparseBLAS1.f90' module SparseBLAS1 use mod_usconv_coo2csr use mod_usconv_coo2csc use mod_usconv_csr2coo use mod_usconv_csc2coo use mod_usconv_coo2dia use mod_usconv_dia2coo use mod_usconv_bco2bsr use mod_usconv_bco2bsc use mod_usconv_bsr2bco use mod_usconv_bsc2bco use mod_usconv_bco2bdi use mod_usconv_bdi2bco use mod_usdot use mod_usaxpy use mod_usga use mod_usgz use mod_ussc use SparseBLAS use properties end module SparseBLAS1 SHAR_EOF fi # end of overwriting check if test -f 'blas_sparse.f90' then echo shar: will not over-write existing file "'blas_sparse.f90'" else cat << "SHAR_EOF" > 'blas_sparse.f90' module blas_sparse use blas_sparse_namedconstants use blas_sparse_proto end module blas_sparse SHAR_EOF fi # end of overwriting check if test -f 'blas_sparse_namedconstants.f90' then echo shar: will not over-write existing file "'blas_sparse_namedconstants.f90'" else cat << "SHAR_EOF" > 'blas_sparse_namedconstants.f90' module blas_sparse_namedconstants ! *** Diagonal entries integer, parameter :: blas_non_unit_diag = 0 !DEFAULT integer, parameter :: blas_unit_diag = 1 ! *** Indices integer, parameter :: blas_no_repeated_indices = 0 !DEFAULT integer, parameter :: blas_repeated_indices = 2 ! *** Use only one half of the matrix: for sym, herm, triang. matrices integer, parameter :: blas_upper = 4 integer, parameter :: blas_lower = 8 ! *** structured/unstructured matrix integer, parameter :: blas_irregular = 0 !DEFAULT integer, parameter :: blas_regular = 16 integer, parameter :: blas_block_irregular = 0 !DEFAULT integer, parameter :: blas_block_regular = 16 integer, parameter :: blas_unassembled = 32 ! *** Index basis of matrix elements integer, parameter :: blas_one_base = 0 !DEFAULT integer, parameter :: blas_zero_base = 64 ! *** Matrix type integer, parameter :: blas_general = 0 !DEFAULT integer, parameter :: blas_symmetric = 128 integer, parameter :: blas_upper_symmetric = 132 integer, parameter :: blas_lower_symmetric = 136 integer, parameter :: blas_hermitian = 256 integer, parameter :: blas_upper_hermitian = 260 integer, parameter :: blas_lower_hermitian = 264 integer, parameter :: blas_upper_triangular = 516 integer, parameter :: blas_lower_triangular = 520 ! *** For block matrices: specify block-internal storage integer, parameter :: blas_col_major = 0 !DEFAULT integer, parameter :: blas_row_major = 1024 ! *** Other constants integer, parameter :: blas_valid_handle = -1 integer, parameter :: blas_invalid_handle = -10 integer, parameter :: blas_new_handle = -11 integer, parameter :: blas_open_handle = -12 integer, parameter :: blas_real = -2 integer, parameter :: blas_complex = -3 integer, parameter :: blas_integer = -4 integer, parameter :: blas_single_precision = -5 integer, parameter :: blas_double_precision = -6 integer, parameter :: blas_num_rows = -7 integer, parameter :: blas_num_cols = -8 integer, parameter :: blas_num_nonzeros = -9 ! *** Error codes integer, parameter :: blas_error_memalloc = -20 integer, parameter :: blas_error_memdeloc = -21 integer, parameter :: blas_error_singtria = -22 integer, parameter :: blas_error_param = -23 ! *** Definition of numerical precisions integer, parameter :: sp = SELECTED_REAL_KIND(6,37) integer, parameter :: dp = SELECTED_REAL_KIND(15,307) end module blas_sparse_namedconstants SHAR_EOF fi # end of overwriting check if test -f 'blas_sparse_proto.f90' then echo shar: will not over-write existing file "'blas_sparse_proto.f90'" else cat << "SHAR_EOF" > 'blas_sparse_proto.f90' module blas_sparse_proto use SparseBLAS1 use mod_Entry end module blas_sparse_proto SHAR_EOF fi # end of overwriting check if test -f 'conv_tools.f90' then echo shar: will not over-write existing file "'conv_tools.f90'" else cat << "SHAR_EOF" > 'conv_tools.f90' module mod_conv_tools use blas_sparse_namedconstants interface b_up_order module procedure ib_up_order module procedure sb_up_order module procedure db_up_order module procedure cb_up_order module procedure zb_up_order end interface interface A_row_col module procedure iA_row_col module procedure sA_row_col module procedure dA_row_col module procedure cA_row_col module procedure zA_row_col end interface interface detect_diag module procedure idetect_diag module procedure sdetect_diag module procedure ddetect_diag module procedure cdetect_diag module procedure zdetect_diag end interface interface Ab_row_col module procedure iAb_row_col module procedure sAb_row_col module procedure dAb_row_col module procedure cAb_row_col module procedure zAb_row_col end interface interface detect_bdiag module procedure idetect_bdiag module procedure sdetect_bdiag module procedure ddetect_bdiag module procedure cdetect_bdiag module procedure zdetect_bdiag end interface interface pre_usconv_coo2csr module procedure ipre_usconv_coo2csr module procedure spre_usconv_coo2csr module procedure dpre_usconv_coo2csr module procedure cpre_usconv_coo2csr module procedure zpre_usconv_coo2csr end interface interface pre_usconv_coo2csc module procedure ipre_usconv_coo2csc module procedure spre_usconv_coo2csc module procedure dpre_usconv_coo2csc module procedure cpre_usconv_coo2csc module procedure zpre_usconv_coo2csc end interface interface pre_usconv_bco2bsc module procedure ipre_usconv_bco2bsc module procedure spre_usconv_bco2bsc module procedure dpre_usconv_bco2bsc module procedure cpre_usconv_bco2bsc module procedure zpre_usconv_bco2bsc end interface interface pre_usconv_bco2bsr module procedure ipre_usconv_bco2bsr module procedure spre_usconv_bco2bsr module procedure dpre_usconv_bco2bsr module procedure cpre_usconv_bco2bsr module procedure zpre_usconv_bco2bsr end interface interface pre_usconv_coo2dia module procedure ipre_usconv_coo2dia module procedure spre_usconv_coo2dia module procedure dpre_usconv_coo2dia module procedure cpre_usconv_coo2dia module procedure zpre_usconv_coo2dia end interface interface pre_usconv_dia2coo module procedure ipre_usconv_dia2coo module procedure spre_usconv_dia2coo module procedure dpre_usconv_dia2coo module procedure cpre_usconv_dia2coo module procedure zpre_usconv_dia2coo end interface interface pre_usconv_bco2bdi module procedure ipre_usconv_bco2bdi module procedure spre_usconv_bco2bdi module procedure dpre_usconv_bco2bdi module procedure cpre_usconv_bco2bdi module procedure zpre_usconv_bco2bdi end interface interface pre_usconv_bdi2bco module procedure ipre_usconv_bdi2bco module procedure spre_usconv_bdi2bco module procedure dpre_usconv_bdi2bco module procedure cpre_usconv_bdi2bco module procedure zpre_usconv_bdi2bco end interface contains subroutine up_order(INDX,RES_INDX) implicit none integer,pointer,dimension(:) ::INDX integer,dimension(:),allocatable ::tes integer,pointer,dimension(:) ::RES_INDX integer,dimension(1)::c integer ::i,s integer :: dummy intrinsic maxval intrinsic minloc s=size(INDX) allocate(tes(s)) tes=INDX dummy = maxval(tes)+1 do i=1,s c=minloc(tes) RES_INDX(i)=c(1) tes(c(1))=dummy end do deallocate(tes) end subroutine up_order function counter(INDX,value) implicit none integer ,pointer,dimension(:)::INDX integer ,intent(in)::value integer ::counter,s,j,k s=size(INDX) k=0 do j=1,s if(INDX(j)==value) then k=k+1 end if end do counter=k end function counter subroutine PNTR(PNTRB,PNTRE,M_K,INDX) implicit none integer ,pointer,dimension(:)::PNTRB,PNTRE integer ,pointer,dimension(:) :: INDX integer ,intent(in) :: M_K integer ::j,s s=size(INDX) PNTRB(1)=1 PNTRE(M_K)=s+1 do j=2,M_K PNTRB(j)=PNTRB(j-1)+counter(INDX,j-1) PNTRE(j-1)=PNTRB(j) end do end subroutine PNTR subroutine final_order(JNDX,final_indx,row_subdv) implicit none integer,pointer,dimension(:)::JNDX,row_subdv integer,pointer,dimension(:)::final_indx integer,pointer,dimension(:) :: test_int,test_ind integer ::d,k,s,i d=1 s=size(row_subdv) do i=1,s if(row_subdv(i)>0) then allocate(test_int(row_subdv(i))) allocate(test_ind(row_subdv(i))) test_int=JNDX((/(i,i=d,d+row_subdv(i)-1,1)/)) call up_order(test_int,test_ind) do k=1,row_subdv(i) final_indx(d+k-1)=test_ind(k)+d-1 end do deallocate(test_int) deallocate(test_ind) end if d=d+row_subdv(i) end do end subroutine final_order subroutine PNTR_INV(PNTRE,INDX) implicit none integer,pointer ,dimension(:)::PNTRE integer,pointer ,dimension(:)::INDX integer :: i,j,s s=size(PNTRE) do j=1,PNTRE(1)-1 INDX(j)=1 end do do i=1,s-1 if(PNTRE(i).ne.PNTRE(i+1)) then do j=PNTRE(i),PNTRE(i+1)-1 INDX(j)=i+1 end do end if end do end subroutine PNTR_INV subroutine ib_up_order (VAL,lbxlb,BINDX) implicit none integer ,pointer ,dimension(:)::VAL integer ,pointer, dimension(:)::BINDX integer ,dimension(:),allocatable :: tes integer ,dimension(:,:),allocatable::P integer ,intent(in) ::lbxlb integer ::s,i,j,k allocate(tes(lbxlb)) do i=1,lbxlb tes(i)=i end do s=size(VAL) k=floor(real(s/lbxlb)) allocate(P(lbxlb,k)) do j=1,s i=floor(real((j-1)/lbxlb)) P(j-i*lbxlb,i+1)=VAL(j) end do P=P(tes,BINDX) do j=1,s i=floor(real((j-1)/lbxlb)) VAL(j)=P(j-i*lbxlb,i+1) end do deallocate(tes,P) end subroutine ib_up_order function iA_row_col (VAL,INDX,JNDX,i,j) integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::i,j integer::k logical::finder integer :: iA_row_col finder=.false. k=1 do while((k.le.size(VAL)).and.(.not.finder)) if(INDX(k).eq.i.and.JNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then iA_row_col =VAL(k) else iA_row_col =0 end if end function iA_row_col subroutine idetect_diag (VAL,INDX,JNDX,ind,LDA,test) implicit none integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::ind,LDA integer,intent(inout)::test logical::finder integer ::val_val integer ::k test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.LDA).and.(.not.finder)) val_val= iA_row_col (VAL,INDX,JNDX,k,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k,k+ind) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k-ind,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine idetect_diag function iAb_row_col (VAL,BINDX,BJNDX,i,j,sub_ind,lb) integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::i,j,sub_ind,lb integer::k,dummy logical::finder integer :: iAb_row_col dummy=lb*lb finder=.false. k=1 do while((k.le.size(BINDX)).and.(.not.finder)) if(BINDX(k).eq.i.and.BJNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then iAb_row_col =VAL(dummy*(k-1)+sub_ind) else iAb_row_col =0. end if end function iAb_row_col subroutine idetect_bdiag (VAL,BINDX,BJNDX,ind,BLDA,test,lb) implicit none integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::ind,BLDA,lb integer,intent(inout)::test logical::finder,sub_finder integer ::val_val integer ::k,sub_ind,dummy dummy=lb*lb test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 !do while((k.le.BLDA+ind).and.(.not.finder)) do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k+ind,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k-ind,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine idetect_bdiag subroutine ipre_usconv_coo2dia (m,n,VAL,INDX,JNDX,LDA,NDIAG) implicit none integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,dimension(:),allocatable::IDIAG integer ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::m,n integer,intent(inout)::LDA,NDIAG integer :: i,test,ind,j,k,IDIAG_ind integer :: VAL_ind,VAL_DIA_size intrinsic min LDA=min(m,n) test=0 VAL_ind=0 IDIAG_ind=0 NDIAG=0 ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then NDIAG = NDIAG+1 end if do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do VAL_DIA_size=NDIAG*LDA allocate(IDIAG(NDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then do i=1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,i,i) end do IDIAG(IDIAG_ind+1)=0 IDIAG_ind=IDIAG_ind+1 end if !**********low diag *********** do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then do k=1,i VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do do k=i+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k-i) end do IDIAG(IDIAG_ind+1)=-i IDIAG_ind=IDIAG_ind+1 end if end do !*********** high diag ******* do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then do k=1,LDA-j VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k+j) end do do k=LDA-j+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do IDIAG(IDIAG_ind+1)=j IDIAG_ind=IDIAG_ind+1 end if end do deallocate(VAL,INDX) allocate(VAL(VAL_DIA_size),INDX(NDIAG)) VAL=VAL_DIA INDX=IDIAG deallocate(VAL_DIA) deallocate(IDIAG) end subroutine ipre_usconv_coo2dia subroutine ipre_usconv_dia2coo (VAL_DIA,IDIAG,IA2,LDA,NNZ) implicit none integer ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) :: IDIAG,IA2 integer,intent(in)::LDA,NNZ integer ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::INDX,JNDX integer:: VAL_size,i,k integer::VAL_ind,IND_ind,VAL_DIA_ind VAL_size =NNZ allocate(VAL( VAL_size),INDX( VAL_size),JNDX( VAL_size)) VAL=0. INDX=0. JNDX=0. VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(IDIAG) if(IDIAG(i).lt.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k+IDIAG(i) end if end do elseif(IDIAG(i).eq.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k end if end do else do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA(VAL_DIA_ind ) JNDX(IND_ind)=IDIAG(i)+k INDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,IDIAG,IA2) allocate(VAL_DIA( VAL_size),IDIAG( VAL_size),IA2( VAL_size)) VAL_DIA=VAL IDIAG=INDX IA2=JNDX deallocate(VAL,INDX,JNDX) end subroutine ipre_usconv_dia2coo subroutine ipre_usconv_bco2bdi (mb,kb,lb,VAL,BINDX,BJNDX,BLDA,BNDIAG) implicit none integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,dimension(:),allocatable::BIDIAG integer ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::mb,kb,lb integer,intent(inout)::BLDA,BNDIAG integer :: i,test,ind,j,k,BIDIAG_ind,VAL_ind integer ::VAL_DIA_size,dummy,sub_ind intrinsic min BLDA=min(mb,kb) dummy=lb*lb test=0 VAL_ind=0 BIDIAG_ind=0 BNDIAG=0 ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then BNDIAG = BNDIAG+1 end if do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do VAL_DIA_size=BNDIAG*BLDA*dummy allocate(BIDIAG(BNDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then do i=1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,i,i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=0 BIDIAG_ind=BIDIAG_ind+1 end if !**********low diag *********** do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then do k=1,i do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do do k=i+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k-i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=-i BIDIAG_ind=BIDIAG_ind+1 end if end do !*********** high diag ******* do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then do k=1,BLDA-j do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k+j,sub_ind,lb) end do end do do k=BLDA-j+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do BIDIAG(BIDIAG_ind+1)=j BIDIAG_ind=BIDIAG_ind+1 end if end do deallocate(VAL,BINDX) allocate(VAL(VAL_DIA_size),BINDX(BNDIAG)) VAL=VAL_DIA BINDX=BIDIAG deallocate(VAL_DIA) deallocate(BIDIAG) end subroutine ipre_usconv_bco2bdi subroutine ipre_usconv_bdi2bco (VAL_DIA,BIDIAG,IA2,BLDA,BNNZ,lb) implicit none integer ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) ::BIDIAG,IA2 integer,intent(in)::BLDA,lb integer,intent(out)::BNNZ integer ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::BINDX,BJNDX integer ::val_val integer:: VAL_size,i,k,VAL_ind,IND_ind integer::VAL_DIA_ind,dummy,sub_ind,NB_BLOCKS,dummy2 logical ::sub_finder intrinsic floor dummy=lb*lb NB_BLOCKS=floor(real(size(VAL_DIA)/dummy)) BNNZ=0 do VAL_DIA_ind=1,NB_BLOCKS sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then BNNZ=BNNZ+1 end if end do VAL_size =BNNZ allocate(VAL(dummy*VAL_size),BINDX(VAL_size)) allocate(BJNDX(VAL_size)) VAL=0. BINDX=0 BJNDX=0 VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(BIDIAG) if(BIDIAG(i).lt.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k+BIDIAG(i) end if end do elseif(BIDIAG(i).eq.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k end if end do else do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BJNDX(IND_ind)=BIDIAG(i)+k BINDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,BIDIAG,IA2) allocate(VAL_DIA(dummy*VAL_size),BIDIAG(VAL_size)) allocate(IA2(VAL_size)) VAL_DIA=VAL BIDIAG=BINDX IA2=BJNDX deallocate(VAL,BINDX,BJNDX) end subroutine ipre_usconv_bdi2bco subroutine ipre_usconv_coo2csr (VAL,INDX,JNDX,M,PNTRB,PNTRE) implicit none integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::M integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(INDX) allocate(DV(M)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,M DV(i)=counter(INDX,i) end do call PNTR(PNTRB,PNTRE,M,INDX) call up_order(INDX,ORD_RES) INDX=JNDX VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine ipre_usconv_coo2csr subroutine ipre_usconv_coo2csc (VAL,INDX,JNDX,K,PNTRB,PNTRE) implicit none integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::K integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(JNDX) allocate(DV(K)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,K DV(i)=counter(JNDX,i) end do allocate(DV(K+1)) call PNTR(PNTRB,PNTRE,K,JNDX) call up_order(JNDX,ORD_RES) VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine ipre_usconv_coo2csc subroutine ipre_usconv_bco2bsr (VAL,BINDX,BJNDX,MB,LB,BPNTRB,BPNTRE) implicit none integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::MB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BINDX) dummy=LB*LB allocate(DV(MB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,MB DV(i)=counter(BINDX,i) end do call PNTR(BPNTRB,BPNTRE,MB,BINDX) call up_order(BINDX,ORD_RES) BINDX=BJNDX call ib_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call ib_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine ipre_usconv_bco2bsr subroutine ipre_usconv_bco2bsc (VAL,BINDX,BJNDX,KB,LB,BPNTRB,BPNTRE) implicit none integer ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::KB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BJNDX) dummy=LB*LB allocate(DV(KB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,KB DV(i)=counter(BJNDX,i) end do DV(KB+1)=counter(BJNDX,-1) call PNTR(BPNTRB,BPNTRE,KB,BJNDX) call up_order(BJNDX,ORD_RES) call ib_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call ib_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine ipre_usconv_bco2bsc subroutine sb_up_order (VAL,lbxlb,BINDX) implicit none real(KIND=sp) ,pointer ,dimension(:)::VAL integer ,pointer, dimension(:)::BINDX integer ,dimension(:),allocatable :: tes real(KIND=sp) ,dimension(:,:),allocatable::P integer ,intent(in) ::lbxlb integer ::s,i,j,k allocate(tes(lbxlb)) do i=1,lbxlb tes(i)=i end do s=size(VAL) k=floor(real(s/lbxlb)) allocate(P(lbxlb,k)) do j=1,s i=floor(real((j-1)/lbxlb)) P(j-i*lbxlb,i+1)=VAL(j) end do P=P(tes,BINDX) do j=1,s i=floor(real((j-1)/lbxlb)) VAL(j)=P(j-i*lbxlb,i+1) end do deallocate(tes,P) end subroutine sb_up_order function sA_row_col (VAL,INDX,JNDX,i,j) real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::i,j integer::k logical::finder real(KIND=sp) :: sA_row_col finder=.false. k=1 do while((k.le.size(VAL)).and.(.not.finder)) if(INDX(k).eq.i.and.JNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then sA_row_col =VAL(k) else sA_row_col =0 end if end function sA_row_col subroutine sdetect_diag (VAL,INDX,JNDX,ind,LDA,test) implicit none real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::ind,LDA integer,intent(inout)::test logical::finder real(KIND=sp) ::val_val integer ::k test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.LDA).and.(.not.finder)) val_val= sA_row_col (VAL,INDX,JNDX,k,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k,k+ind) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k-ind,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine sdetect_diag function sAb_row_col (VAL,BINDX,BJNDX,i,j,sub_ind,lb) real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::i,j,sub_ind,lb integer::k,dummy logical::finder real(KIND=sp) :: sAb_row_col dummy=lb*lb finder=.false. k=1 do while((k.le.size(BINDX)).and.(.not.finder)) if(BINDX(k).eq.i.and.BJNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then sAb_row_col =VAL(dummy*(k-1)+sub_ind) else sAb_row_col =0. end if end function sAb_row_col subroutine sdetect_bdiag (VAL,BINDX,BJNDX,ind,BLDA,test,lb) implicit none real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::ind,BLDA,lb integer,intent(inout)::test logical::finder,sub_finder real(KIND=sp) ::val_val integer ::k,sub_ind,dummy dummy=lb*lb test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 !do while((k.le.BLDA+ind).and.(.not.finder)) do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k+ind,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k-ind,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine sdetect_bdiag subroutine spre_usconv_coo2dia (m,n,VAL,INDX,JNDX,LDA,NDIAG) implicit none real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,dimension(:),allocatable::IDIAG real(KIND=sp) ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::m,n integer,intent(inout)::LDA,NDIAG integer :: i,test,ind,j,k,IDIAG_ind integer :: VAL_ind,VAL_DIA_size intrinsic min LDA=min(m,n) test=0 VAL_ind=0 IDIAG_ind=0 NDIAG=0 ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then NDIAG = NDIAG+1 end if do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do VAL_DIA_size=NDIAG*LDA allocate(IDIAG(NDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then do i=1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,i,i) end do IDIAG(IDIAG_ind+1)=0 IDIAG_ind=IDIAG_ind+1 end if !**********low diag *********** do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then do k=1,i VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do do k=i+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k-i) end do IDIAG(IDIAG_ind+1)=-i IDIAG_ind=IDIAG_ind+1 end if end do !*********** high diag ******* do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then do k=1,LDA-j VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k+j) end do do k=LDA-j+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do IDIAG(IDIAG_ind+1)=j IDIAG_ind=IDIAG_ind+1 end if end do deallocate(VAL,INDX) allocate(VAL(VAL_DIA_size),INDX(NDIAG)) VAL=VAL_DIA INDX=IDIAG deallocate(VAL_DIA) deallocate(IDIAG) end subroutine spre_usconv_coo2dia subroutine spre_usconv_dia2coo (VAL_DIA,IDIAG,IA2,LDA,NNZ) implicit none real(KIND=sp) ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) :: IDIAG,IA2 integer,intent(in)::LDA,NNZ real(KIND=sp) ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::INDX,JNDX integer:: VAL_size,i,k integer::VAL_ind,IND_ind,VAL_DIA_ind VAL_size =NNZ allocate(VAL( VAL_size),INDX( VAL_size),JNDX( VAL_size)) VAL=0. INDX=0. JNDX=0. VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(IDIAG) if(IDIAG(i).lt.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k+IDIAG(i) end if end do elseif(IDIAG(i).eq.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k end if end do else do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA(VAL_DIA_ind ) JNDX(IND_ind)=IDIAG(i)+k INDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,IDIAG,IA2) allocate(VAL_DIA( VAL_size),IDIAG( VAL_size),IA2( VAL_size)) VAL_DIA=VAL IDIAG=INDX IA2=JNDX deallocate(VAL,INDX,JNDX) end subroutine spre_usconv_dia2coo subroutine spre_usconv_bco2bdi (mb,kb,lb,VAL,BINDX,BJNDX,BLDA,BNDIAG) implicit none real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,dimension(:),allocatable::BIDIAG real(KIND=sp) ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::mb,kb,lb integer,intent(inout)::BLDA,BNDIAG integer :: i,test,ind,j,k,BIDIAG_ind,VAL_ind integer ::VAL_DIA_size,dummy,sub_ind intrinsic min BLDA=min(mb,kb) dummy=lb*lb test=0 VAL_ind=0 BIDIAG_ind=0 BNDIAG=0 ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then BNDIAG = BNDIAG+1 end if do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do VAL_DIA_size=BNDIAG*BLDA*dummy allocate(BIDIAG(BNDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then do i=1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,i,i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=0 BIDIAG_ind=BIDIAG_ind+1 end if !**********low diag *********** do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then do k=1,i do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do do k=i+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k-i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=-i BIDIAG_ind=BIDIAG_ind+1 end if end do !*********** high diag ******* do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then do k=1,BLDA-j do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k+j,sub_ind,lb) end do end do do k=BLDA-j+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do BIDIAG(BIDIAG_ind+1)=j BIDIAG_ind=BIDIAG_ind+1 end if end do deallocate(VAL,BINDX) allocate(VAL(VAL_DIA_size),BINDX(BNDIAG)) VAL=VAL_DIA BINDX=BIDIAG deallocate(VAL_DIA) deallocate(BIDIAG) end subroutine spre_usconv_bco2bdi subroutine spre_usconv_bdi2bco (VAL_DIA,BIDIAG,IA2,BLDA,BNNZ,lb) implicit none real(KIND=sp) ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) ::BIDIAG,IA2 integer,intent(in)::BLDA,lb integer,intent(out)::BNNZ integer ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::BINDX,BJNDX real(KIND=sp) ::val_val integer:: VAL_size,i,k,VAL_ind,IND_ind integer::VAL_DIA_ind,dummy,sub_ind,NB_BLOCKS,dummy2 logical ::sub_finder intrinsic floor dummy=lb*lb NB_BLOCKS=floor(real(size(VAL_DIA)/dummy)) BNNZ=0 do VAL_DIA_ind=1,NB_BLOCKS sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then BNNZ=BNNZ+1 end if end do VAL_size =BNNZ allocate(VAL(dummy*VAL_size),BINDX(VAL_size)) allocate(BJNDX(VAL_size)) VAL=0. BINDX=0 BJNDX=0 VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(BIDIAG) if(BIDIAG(i).lt.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k+BIDIAG(i) end if end do elseif(BIDIAG(i).eq.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k end if end do else do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BJNDX(IND_ind)=BIDIAG(i)+k BINDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,BIDIAG,IA2) allocate(VAL_DIA(dummy*VAL_size),BIDIAG(VAL_size)) allocate(IA2(VAL_size)) VAL_DIA=VAL BIDIAG=BINDX IA2=BJNDX deallocate(VAL,BINDX,BJNDX) end subroutine spre_usconv_bdi2bco subroutine spre_usconv_coo2csr (VAL,INDX,JNDX,M,PNTRB,PNTRE) implicit none real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::M integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(INDX) allocate(DV(M)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,M DV(i)=counter(INDX,i) end do call PNTR(PNTRB,PNTRE,M,INDX) call up_order(INDX,ORD_RES) INDX=JNDX VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine spre_usconv_coo2csr subroutine spre_usconv_coo2csc (VAL,INDX,JNDX,K,PNTRB,PNTRE) implicit none real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::K integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(JNDX) allocate(DV(K)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,K DV(i)=counter(JNDX,i) end do allocate(DV(K+1)) call PNTR(PNTRB,PNTRE,K,JNDX) call up_order(JNDX,ORD_RES) VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine spre_usconv_coo2csc subroutine spre_usconv_bco2bsr (VAL,BINDX,BJNDX,MB,LB,BPNTRB,BPNTRE) implicit none real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::MB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BINDX) dummy=LB*LB allocate(DV(MB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,MB DV(i)=counter(BINDX,i) end do call PNTR(BPNTRB,BPNTRE,MB,BINDX) call up_order(BINDX,ORD_RES) BINDX=BJNDX call sb_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call sb_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine spre_usconv_bco2bsr subroutine spre_usconv_bco2bsc (VAL,BINDX,BJNDX,KB,LB,BPNTRB,BPNTRE) implicit none real(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::KB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BJNDX) dummy=LB*LB allocate(DV(KB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,KB DV(i)=counter(BJNDX,i) end do DV(KB+1)=counter(BJNDX,-1) call PNTR(BPNTRB,BPNTRE,KB,BJNDX) call up_order(BJNDX,ORD_RES) call sb_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call sb_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine spre_usconv_bco2bsc subroutine db_up_order (VAL,lbxlb,BINDX) implicit none real(KIND=dp) ,pointer ,dimension(:)::VAL integer ,pointer, dimension(:)::BINDX integer ,dimension(:),allocatable :: tes real(KIND=dp) ,dimension(:,:),allocatable::P integer ,intent(in) ::lbxlb integer ::s,i,j,k allocate(tes(lbxlb)) do i=1,lbxlb tes(i)=i end do s=size(VAL) k=floor(real(s/lbxlb)) allocate(P(lbxlb,k)) do j=1,s i=floor(real((j-1)/lbxlb)) P(j-i*lbxlb,i+1)=VAL(j) end do P=P(tes,BINDX) do j=1,s i=floor(real((j-1)/lbxlb)) VAL(j)=P(j-i*lbxlb,i+1) end do deallocate(tes,P) end subroutine db_up_order function dA_row_col (VAL,INDX,JNDX,i,j) real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::i,j integer::k logical::finder real(KIND=dp) :: dA_row_col finder=.false. k=1 do while((k.le.size(VAL)).and.(.not.finder)) if(INDX(k).eq.i.and.JNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then dA_row_col =VAL(k) else dA_row_col =0 end if end function dA_row_col subroutine ddetect_diag (VAL,INDX,JNDX,ind,LDA,test) implicit none real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::ind,LDA integer,intent(inout)::test logical::finder real(KIND=dp) ::val_val integer ::k test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.LDA).and.(.not.finder)) val_val= dA_row_col (VAL,INDX,JNDX,k,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k,k+ind) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k-ind,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine ddetect_diag function dAb_row_col (VAL,BINDX,BJNDX,i,j,sub_ind,lb) real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::i,j,sub_ind,lb integer::k,dummy logical::finder real(KIND=dp) :: dAb_row_col dummy=lb*lb finder=.false. k=1 do while((k.le.size(BINDX)).and.(.not.finder)) if(BINDX(k).eq.i.and.BJNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then dAb_row_col =VAL(dummy*(k-1)+sub_ind) else dAb_row_col =0. end if end function dAb_row_col subroutine ddetect_bdiag (VAL,BINDX,BJNDX,ind,BLDA,test,lb) implicit none real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::ind,BLDA,lb integer,intent(inout)::test logical::finder,sub_finder real(KIND=dp) ::val_val integer ::k,sub_ind,dummy dummy=lb*lb test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 !do while((k.le.BLDA+ind).and.(.not.finder)) do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k+ind,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k-ind,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine ddetect_bdiag subroutine dpre_usconv_coo2dia (m,n,VAL,INDX,JNDX,LDA,NDIAG) implicit none real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,dimension(:),allocatable::IDIAG real(KIND=dp) ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::m,n integer,intent(inout)::LDA,NDIAG integer :: i,test,ind,j,k,IDIAG_ind integer :: VAL_ind,VAL_DIA_size intrinsic min LDA=min(m,n) test=0 VAL_ind=0 IDIAG_ind=0 NDIAG=0 ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then NDIAG = NDIAG+1 end if do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do VAL_DIA_size=NDIAG*LDA allocate(IDIAG(NDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then do i=1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,i,i) end do IDIAG(IDIAG_ind+1)=0 IDIAG_ind=IDIAG_ind+1 end if !**********low diag *********** do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then do k=1,i VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do do k=i+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k-i) end do IDIAG(IDIAG_ind+1)=-i IDIAG_ind=IDIAG_ind+1 end if end do !*********** high diag ******* do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then do k=1,LDA-j VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k+j) end do do k=LDA-j+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do IDIAG(IDIAG_ind+1)=j IDIAG_ind=IDIAG_ind+1 end if end do deallocate(VAL,INDX) allocate(VAL(VAL_DIA_size),INDX(NDIAG)) VAL=VAL_DIA INDX=IDIAG deallocate(VAL_DIA) deallocate(IDIAG) end subroutine dpre_usconv_coo2dia subroutine dpre_usconv_dia2coo (VAL_DIA,IDIAG,IA2,LDA,NNZ) implicit none real(KIND=dp) ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) :: IDIAG,IA2 integer,intent(in)::LDA,NNZ real(KIND=dp) ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::INDX,JNDX integer:: VAL_size,i,k integer::VAL_ind,IND_ind,VAL_DIA_ind VAL_size =NNZ allocate(VAL( VAL_size),INDX( VAL_size),JNDX( VAL_size)) VAL=0. INDX=0. JNDX=0. VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(IDIAG) if(IDIAG(i).lt.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k+IDIAG(i) end if end do elseif(IDIAG(i).eq.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k end if end do else do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA(VAL_DIA_ind ) JNDX(IND_ind)=IDIAG(i)+k INDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,IDIAG,IA2) allocate(VAL_DIA( VAL_size),IDIAG( VAL_size),IA2( VAL_size)) VAL_DIA=VAL IDIAG=INDX IA2=JNDX deallocate(VAL,INDX,JNDX) end subroutine dpre_usconv_dia2coo subroutine dpre_usconv_bco2bdi (mb,kb,lb,VAL,BINDX,BJNDX,BLDA,BNDIAG) implicit none real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,dimension(:),allocatable::BIDIAG real(KIND=dp) ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::mb,kb,lb integer,intent(inout)::BLDA,BNDIAG integer :: i,test,ind,j,k,BIDIAG_ind,VAL_ind integer ::VAL_DIA_size,dummy,sub_ind intrinsic min BLDA=min(mb,kb) dummy=lb*lb test=0 VAL_ind=0 BIDIAG_ind=0 BNDIAG=0 ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then BNDIAG = BNDIAG+1 end if do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do VAL_DIA_size=BNDIAG*BLDA*dummy allocate(BIDIAG(BNDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then do i=1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,i,i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=0 BIDIAG_ind=BIDIAG_ind+1 end if !**********low diag *********** do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then do k=1,i do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do do k=i+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k-i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=-i BIDIAG_ind=BIDIAG_ind+1 end if end do !*********** high diag ******* do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then do k=1,BLDA-j do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k+j,sub_ind,lb) end do end do do k=BLDA-j+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do BIDIAG(BIDIAG_ind+1)=j BIDIAG_ind=BIDIAG_ind+1 end if end do deallocate(VAL,BINDX) allocate(VAL(VAL_DIA_size),BINDX(BNDIAG)) VAL=VAL_DIA BINDX=BIDIAG deallocate(VAL_DIA) deallocate(BIDIAG) end subroutine dpre_usconv_bco2bdi subroutine dpre_usconv_bdi2bco (VAL_DIA,BIDIAG,IA2,BLDA,BNNZ,lb) implicit none real(KIND=dp) ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) ::BIDIAG,IA2 integer,intent(in)::BLDA,lb integer,intent(out)::BNNZ integer ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::BINDX,BJNDX real(KIND=dp) ::val_val integer:: VAL_size,i,k,VAL_ind,IND_ind integer::VAL_DIA_ind,dummy,sub_ind,NB_BLOCKS,dummy2 logical ::sub_finder intrinsic floor dummy=lb*lb NB_BLOCKS=floor(real(size(VAL_DIA)/dummy)) BNNZ=0 do VAL_DIA_ind=1,NB_BLOCKS sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then BNNZ=BNNZ+1 end if end do VAL_size =BNNZ allocate(VAL(dummy*VAL_size),BINDX(VAL_size)) allocate(BJNDX(VAL_size)) VAL=0. BINDX=0 BJNDX=0 VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(BIDIAG) if(BIDIAG(i).lt.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k+BIDIAG(i) end if end do elseif(BIDIAG(i).eq.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k end if end do else do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BJNDX(IND_ind)=BIDIAG(i)+k BINDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,BIDIAG,IA2) allocate(VAL_DIA(dummy*VAL_size),BIDIAG(VAL_size)) allocate(IA2(VAL_size)) VAL_DIA=VAL BIDIAG=BINDX IA2=BJNDX deallocate(VAL,BINDX,BJNDX) end subroutine dpre_usconv_bdi2bco subroutine dpre_usconv_coo2csr (VAL,INDX,JNDX,M,PNTRB,PNTRE) implicit none real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::M integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(INDX) allocate(DV(M)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,M DV(i)=counter(INDX,i) end do call PNTR(PNTRB,PNTRE,M,INDX) call up_order(INDX,ORD_RES) INDX=JNDX VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine dpre_usconv_coo2csr subroutine dpre_usconv_coo2csc (VAL,INDX,JNDX,K,PNTRB,PNTRE) implicit none real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::K integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(JNDX) allocate(DV(K)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,K DV(i)=counter(JNDX,i) end do allocate(DV(K+1)) call PNTR(PNTRB,PNTRE,K,JNDX) call up_order(JNDX,ORD_RES) VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine dpre_usconv_coo2csc subroutine dpre_usconv_bco2bsr (VAL,BINDX,BJNDX,MB,LB,BPNTRB,BPNTRE) implicit none real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::MB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BINDX) dummy=LB*LB allocate(DV(MB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,MB DV(i)=counter(BINDX,i) end do call PNTR(BPNTRB,BPNTRE,MB,BINDX) call up_order(BINDX,ORD_RES) BINDX=BJNDX call db_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call db_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine dpre_usconv_bco2bsr subroutine dpre_usconv_bco2bsc (VAL,BINDX,BJNDX,KB,LB,BPNTRB,BPNTRE) implicit none real(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::KB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BJNDX) dummy=LB*LB allocate(DV(KB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,KB DV(i)=counter(BJNDX,i) end do DV(KB+1)=counter(BJNDX,-1) call PNTR(BPNTRB,BPNTRE,KB,BJNDX) call up_order(BJNDX,ORD_RES) call db_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call db_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine dpre_usconv_bco2bsc subroutine cb_up_order (VAL,lbxlb,BINDX) implicit none complex(KIND=sp) ,pointer ,dimension(:)::VAL integer ,pointer, dimension(:)::BINDX integer ,dimension(:),allocatable :: tes complex(KIND=sp) ,dimension(:,:),allocatable::P integer ,intent(in) ::lbxlb integer ::s,i,j,k allocate(tes(lbxlb)) do i=1,lbxlb tes(i)=i end do s=size(VAL) k=floor(real(s/lbxlb)) allocate(P(lbxlb,k)) do j=1,s i=floor(real((j-1)/lbxlb)) P(j-i*lbxlb,i+1)=VAL(j) end do P=P(tes,BINDX) do j=1,s i=floor(real((j-1)/lbxlb)) VAL(j)=P(j-i*lbxlb,i+1) end do deallocate(tes,P) end subroutine cb_up_order function cA_row_col (VAL,INDX,JNDX,i,j) complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::i,j integer::k logical::finder complex(KIND=sp) :: cA_row_col finder=.false. k=1 do while((k.le.size(VAL)).and.(.not.finder)) if(INDX(k).eq.i.and.JNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then cA_row_col =VAL(k) else cA_row_col =0 end if end function cA_row_col subroutine cdetect_diag (VAL,INDX,JNDX,ind,LDA,test) implicit none complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::ind,LDA integer,intent(inout)::test logical::finder complex(KIND=sp) ::val_val integer ::k test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.LDA).and.(.not.finder)) val_val= cA_row_col (VAL,INDX,JNDX,k,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k,k+ind) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k-ind,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine cdetect_diag function cAb_row_col (VAL,BINDX,BJNDX,i,j,sub_ind,lb) complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::i,j,sub_ind,lb integer::k,dummy logical::finder complex(KIND=sp) :: cAb_row_col dummy=lb*lb finder=.false. k=1 do while((k.le.size(BINDX)).and.(.not.finder)) if(BINDX(k).eq.i.and.BJNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then cAb_row_col =VAL(dummy*(k-1)+sub_ind) else cAb_row_col =0. end if end function cAb_row_col subroutine cdetect_bdiag (VAL,BINDX,BJNDX,ind,BLDA,test,lb) implicit none complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::ind,BLDA,lb integer,intent(inout)::test logical::finder,sub_finder complex(KIND=sp) ::val_val integer ::k,sub_ind,dummy dummy=lb*lb test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 !do while((k.le.BLDA+ind).and.(.not.finder)) do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k+ind,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k-ind,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine cdetect_bdiag subroutine cpre_usconv_coo2dia (m,n,VAL,INDX,JNDX,LDA,NDIAG) implicit none complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,dimension(:),allocatable::IDIAG complex(KIND=sp) ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::m,n integer,intent(inout)::LDA,NDIAG integer :: i,test,ind,j,k,IDIAG_ind integer :: VAL_ind,VAL_DIA_size intrinsic min LDA=min(m,n) test=0 VAL_ind=0 IDIAG_ind=0 NDIAG=0 ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then NDIAG = NDIAG+1 end if do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do VAL_DIA_size=NDIAG*LDA allocate(IDIAG(NDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then do i=1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,i,i) end do IDIAG(IDIAG_ind+1)=0 IDIAG_ind=IDIAG_ind+1 end if !**********low diag *********** do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then do k=1,i VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do do k=i+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k-i) end do IDIAG(IDIAG_ind+1)=-i IDIAG_ind=IDIAG_ind+1 end if end do !*********** high diag ******* do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then do k=1,LDA-j VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k+j) end do do k=LDA-j+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do IDIAG(IDIAG_ind+1)=j IDIAG_ind=IDIAG_ind+1 end if end do deallocate(VAL,INDX) allocate(VAL(VAL_DIA_size),INDX(NDIAG)) VAL=VAL_DIA INDX=IDIAG deallocate(VAL_DIA) deallocate(IDIAG) end subroutine cpre_usconv_coo2dia subroutine cpre_usconv_dia2coo (VAL_DIA,IDIAG,IA2,LDA,NNZ) implicit none complex(KIND=sp) ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) :: IDIAG,IA2 integer,intent(in)::LDA,NNZ complex(KIND=sp) ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::INDX,JNDX integer:: VAL_size,i,k integer::VAL_ind,IND_ind,VAL_DIA_ind VAL_size =NNZ allocate(VAL( VAL_size),INDX( VAL_size),JNDX( VAL_size)) VAL=0. INDX=0. JNDX=0. VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(IDIAG) if(IDIAG(i).lt.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k+IDIAG(i) end if end do elseif(IDIAG(i).eq.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k end if end do else do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA(VAL_DIA_ind ) JNDX(IND_ind)=IDIAG(i)+k INDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,IDIAG,IA2) allocate(VAL_DIA( VAL_size),IDIAG( VAL_size),IA2( VAL_size)) VAL_DIA=VAL IDIAG=INDX IA2=JNDX deallocate(VAL,INDX,JNDX) end subroutine cpre_usconv_dia2coo subroutine cpre_usconv_bco2bdi (mb,kb,lb,VAL,BINDX,BJNDX,BLDA,BNDIAG) implicit none complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,dimension(:),allocatable::BIDIAG complex(KIND=sp) ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::mb,kb,lb integer,intent(inout)::BLDA,BNDIAG integer :: i,test,ind,j,k,BIDIAG_ind,VAL_ind integer ::VAL_DIA_size,dummy,sub_ind intrinsic min BLDA=min(mb,kb) dummy=lb*lb test=0 VAL_ind=0 BIDIAG_ind=0 BNDIAG=0 ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then BNDIAG = BNDIAG+1 end if do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do VAL_DIA_size=BNDIAG*BLDA*dummy allocate(BIDIAG(BNDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then do i=1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,i,i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=0 BIDIAG_ind=BIDIAG_ind+1 end if !**********low diag *********** do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then do k=1,i do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do do k=i+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k-i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=-i BIDIAG_ind=BIDIAG_ind+1 end if end do !*********** high diag ******* do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then do k=1,BLDA-j do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k+j,sub_ind,lb) end do end do do k=BLDA-j+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do BIDIAG(BIDIAG_ind+1)=j BIDIAG_ind=BIDIAG_ind+1 end if end do deallocate(VAL,BINDX) allocate(VAL(VAL_DIA_size),BINDX(BNDIAG)) VAL=VAL_DIA BINDX=BIDIAG deallocate(VAL_DIA) deallocate(BIDIAG) end subroutine cpre_usconv_bco2bdi subroutine cpre_usconv_bdi2bco (VAL_DIA,BIDIAG,IA2,BLDA,BNNZ,lb) implicit none complex(KIND=sp) ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) ::BIDIAG,IA2 integer,intent(in)::BLDA,lb integer,intent(out)::BNNZ integer ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::BINDX,BJNDX complex(KIND=sp) ::val_val integer:: VAL_size,i,k,VAL_ind,IND_ind integer::VAL_DIA_ind,dummy,sub_ind,NB_BLOCKS,dummy2 logical ::sub_finder intrinsic floor dummy=lb*lb NB_BLOCKS=floor(real(size(VAL_DIA)/dummy)) BNNZ=0 do VAL_DIA_ind=1,NB_BLOCKS sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then BNNZ=BNNZ+1 end if end do VAL_size =BNNZ allocate(VAL(dummy*VAL_size),BINDX(VAL_size)) allocate(BJNDX(VAL_size)) VAL=0. BINDX=0 BJNDX=0 VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(BIDIAG) if(BIDIAG(i).lt.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k+BIDIAG(i) end if end do elseif(BIDIAG(i).eq.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k end if end do else do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BJNDX(IND_ind)=BIDIAG(i)+k BINDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,BIDIAG,IA2) allocate(VAL_DIA(dummy*VAL_size),BIDIAG(VAL_size)) allocate(IA2(VAL_size)) VAL_DIA=VAL BIDIAG=BINDX IA2=BJNDX deallocate(VAL,BINDX,BJNDX) end subroutine cpre_usconv_bdi2bco subroutine cpre_usconv_coo2csr (VAL,INDX,JNDX,M,PNTRB,PNTRE) implicit none complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::M integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(INDX) allocate(DV(M)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,M DV(i)=counter(INDX,i) end do call PNTR(PNTRB,PNTRE,M,INDX) call up_order(INDX,ORD_RES) INDX=JNDX VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine cpre_usconv_coo2csr subroutine cpre_usconv_coo2csc (VAL,INDX,JNDX,K,PNTRB,PNTRE) implicit none complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::K integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(JNDX) allocate(DV(K)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,K DV(i)=counter(JNDX,i) end do allocate(DV(K+1)) call PNTR(PNTRB,PNTRE,K,JNDX) call up_order(JNDX,ORD_RES) VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine cpre_usconv_coo2csc subroutine cpre_usconv_bco2bsr (VAL,BINDX,BJNDX,MB,LB,BPNTRB,BPNTRE) implicit none complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::MB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BINDX) dummy=LB*LB allocate(DV(MB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,MB DV(i)=counter(BINDX,i) end do call PNTR(BPNTRB,BPNTRE,MB,BINDX) call up_order(BINDX,ORD_RES) BINDX=BJNDX call cb_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call cb_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine cpre_usconv_bco2bsr subroutine cpre_usconv_bco2bsc (VAL,BINDX,BJNDX,KB,LB,BPNTRB,BPNTRE) implicit none complex(KIND=sp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::KB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BJNDX) dummy=LB*LB allocate(DV(KB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,KB DV(i)=counter(BJNDX,i) end do DV(KB+1)=counter(BJNDX,-1) call PNTR(BPNTRB,BPNTRE,KB,BJNDX) call up_order(BJNDX,ORD_RES) call cb_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call cb_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine cpre_usconv_bco2bsc subroutine zb_up_order (VAL,lbxlb,BINDX) implicit none complex(KIND=dp) ,pointer ,dimension(:)::VAL integer ,pointer, dimension(:)::BINDX integer ,dimension(:),allocatable :: tes complex(KIND=dp) ,dimension(:,:),allocatable::P integer ,intent(in) ::lbxlb integer ::s,i,j,k allocate(tes(lbxlb)) do i=1,lbxlb tes(i)=i end do s=size(VAL) k=floor(real(s/lbxlb)) allocate(P(lbxlb,k)) do j=1,s i=floor(real((j-1)/lbxlb)) P(j-i*lbxlb,i+1)=VAL(j) end do P=P(tes,BINDX) do j=1,s i=floor(real((j-1)/lbxlb)) VAL(j)=P(j-i*lbxlb,i+1) end do deallocate(tes,P) end subroutine zb_up_order function zA_row_col (VAL,INDX,JNDX,i,j) complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::i,j integer::k logical::finder complex(KIND=dp) :: zA_row_col finder=.false. k=1 do while((k.le.size(VAL)).and.(.not.finder)) if(INDX(k).eq.i.and.JNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then zA_row_col =VAL(k) else zA_row_col =0 end if end function zA_row_col subroutine zdetect_diag (VAL,INDX,JNDX,ind,LDA,test) implicit none complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::ind,LDA integer,intent(inout)::test logical::finder complex(KIND=dp) ::val_val integer ::k test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.LDA).and.(.not.finder)) val_val= zA_row_col (VAL,INDX,JNDX,k,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k,k+ind) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k-ind,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine zdetect_diag function zAb_row_col (VAL,BINDX,BJNDX,i,j,sub_ind,lb) complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::i,j,sub_ind,lb integer::k,dummy logical::finder complex(KIND=dp) :: zAb_row_col dummy=lb*lb finder=.false. k=1 do while((k.le.size(BINDX)).and.(.not.finder)) if(BINDX(k).eq.i.and.BJNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then zAb_row_col =VAL(dummy*(k-1)+sub_ind) else zAb_row_col =0. end if end function zAb_row_col subroutine zdetect_bdiag (VAL,BINDX,BJNDX,ind,BLDA,test,lb) implicit none complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::ind,BLDA,lb integer,intent(inout)::test logical::finder,sub_finder complex(KIND=dp) ::val_val integer ::k,sub_ind,dummy dummy=lb*lb test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 !do while((k.le.BLDA+ind).and.(.not.finder)) do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k+ind,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k-ind,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine zdetect_bdiag subroutine zpre_usconv_coo2dia (m,n,VAL,INDX,JNDX,LDA,NDIAG) implicit none complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,dimension(:),allocatable::IDIAG complex(KIND=dp) ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::m,n integer,intent(inout)::LDA,NDIAG integer :: i,test,ind,j,k,IDIAG_ind integer :: VAL_ind,VAL_DIA_size intrinsic min LDA=min(m,n) test=0 VAL_ind=0 IDIAG_ind=0 NDIAG=0 ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then NDIAG = NDIAG+1 end if do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do VAL_DIA_size=NDIAG*LDA allocate(IDIAG(NDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then do i=1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,i,i) end do IDIAG(IDIAG_ind+1)=0 IDIAG_ind=IDIAG_ind+1 end if !**********low diag *********** do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then do k=1,i VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do do k=i+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k-i) end do IDIAG(IDIAG_ind+1)=-i IDIAG_ind=IDIAG_ind+1 end if end do !*********** high diag ******* do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then do k=1,LDA-j VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k+j) end do do k=LDA-j+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do IDIAG(IDIAG_ind+1)=j IDIAG_ind=IDIAG_ind+1 end if end do deallocate(VAL,INDX) allocate(VAL(VAL_DIA_size),INDX(NDIAG)) VAL=VAL_DIA INDX=IDIAG deallocate(VAL_DIA) deallocate(IDIAG) end subroutine zpre_usconv_coo2dia subroutine zpre_usconv_dia2coo (VAL_DIA,IDIAG,IA2,LDA,NNZ) implicit none complex(KIND=dp) ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) :: IDIAG,IA2 integer,intent(in)::LDA,NNZ complex(KIND=dp) ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::INDX,JNDX integer:: VAL_size,i,k integer::VAL_ind,IND_ind,VAL_DIA_ind VAL_size =NNZ allocate(VAL( VAL_size),INDX( VAL_size),JNDX( VAL_size)) VAL=0. INDX=0. JNDX=0. VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(IDIAG) if(IDIAG(i).lt.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k+IDIAG(i) end if end do elseif(IDIAG(i).eq.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k end if end do else do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA(VAL_DIA_ind ) JNDX(IND_ind)=IDIAG(i)+k INDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,IDIAG,IA2) allocate(VAL_DIA( VAL_size),IDIAG( VAL_size),IA2( VAL_size)) VAL_DIA=VAL IDIAG=INDX IA2=JNDX deallocate(VAL,INDX,JNDX) end subroutine zpre_usconv_dia2coo subroutine zpre_usconv_bco2bdi (mb,kb,lb,VAL,BINDX,BJNDX,BLDA,BNDIAG) implicit none complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,dimension(:),allocatable::BIDIAG complex(KIND=dp) ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::mb,kb,lb integer,intent(inout)::BLDA,BNDIAG integer :: i,test,ind,j,k,BIDIAG_ind,VAL_ind integer ::VAL_DIA_size,dummy,sub_ind intrinsic min BLDA=min(mb,kb) dummy=lb*lb test=0 VAL_ind=0 BIDIAG_ind=0 BNDIAG=0 ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then BNDIAG = BNDIAG+1 end if do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do VAL_DIA_size=BNDIAG*BLDA*dummy allocate(BIDIAG(BNDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then do i=1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,i,i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=0 BIDIAG_ind=BIDIAG_ind+1 end if !**********low diag *********** do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then do k=1,i do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do do k=i+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k-i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=-i BIDIAG_ind=BIDIAG_ind+1 end if end do !*********** high diag ******* do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then do k=1,BLDA-j do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k+j,sub_ind,lb) end do end do do k=BLDA-j+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do BIDIAG(BIDIAG_ind+1)=j BIDIAG_ind=BIDIAG_ind+1 end if end do deallocate(VAL,BINDX) allocate(VAL(VAL_DIA_size),BINDX(BNDIAG)) VAL=VAL_DIA BINDX=BIDIAG deallocate(VAL_DIA) deallocate(BIDIAG) end subroutine zpre_usconv_bco2bdi subroutine zpre_usconv_bdi2bco (VAL_DIA,BIDIAG,IA2,BLDA,BNNZ,lb) implicit none complex(KIND=dp) ,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) ::BIDIAG,IA2 integer,intent(in)::BLDA,lb integer,intent(out)::BNNZ integer ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::BINDX,BJNDX complex(KIND=dp) ::val_val integer:: VAL_size,i,k,VAL_ind,IND_ind integer::VAL_DIA_ind,dummy,sub_ind,NB_BLOCKS,dummy2 logical ::sub_finder intrinsic floor dummy=lb*lb NB_BLOCKS=floor(real(size(VAL_DIA)/dummy)) BNNZ=0 do VAL_DIA_ind=1,NB_BLOCKS sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then BNNZ=BNNZ+1 end if end do VAL_size =BNNZ allocate(VAL(dummy*VAL_size),BINDX(VAL_size)) allocate(BJNDX(VAL_size)) VAL=0. BINDX=0 BJNDX=0 VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(BIDIAG) if(BIDIAG(i).lt.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k+BIDIAG(i) end if end do elseif(BIDIAG(i).eq.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k end if end do else do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BJNDX(IND_ind)=BIDIAG(i)+k BINDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,BIDIAG,IA2) allocate(VAL_DIA(dummy*VAL_size),BIDIAG(VAL_size)) allocate(IA2(VAL_size)) VAL_DIA=VAL BIDIAG=BINDX IA2=BJNDX deallocate(VAL,BINDX,BJNDX) end subroutine zpre_usconv_bdi2bco subroutine zpre_usconv_coo2csr (VAL,INDX,JNDX,M,PNTRB,PNTRE) implicit none complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::M integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(INDX) allocate(DV(M)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,M DV(i)=counter(INDX,i) end do call PNTR(PNTRB,PNTRE,M,INDX) call up_order(INDX,ORD_RES) INDX=JNDX VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine zpre_usconv_coo2csr subroutine zpre_usconv_coo2csc (VAL,INDX,JNDX,K,PNTRB,PNTRE) implicit none complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::K integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(JNDX) allocate(DV(K)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,K DV(i)=counter(JNDX,i) end do allocate(DV(K+1)) call PNTR(PNTRB,PNTRE,K,JNDX) call up_order(JNDX,ORD_RES) VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine zpre_usconv_coo2csc subroutine zpre_usconv_bco2bsr (VAL,BINDX,BJNDX,MB,LB,BPNTRB,BPNTRE) implicit none complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::MB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BINDX) dummy=LB*LB allocate(DV(MB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,MB DV(i)=counter(BINDX,i) end do call PNTR(BPNTRB,BPNTRE,MB,BINDX) call up_order(BINDX,ORD_RES) BINDX=BJNDX call zb_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call zb_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine zpre_usconv_bco2bsr subroutine zpre_usconv_bco2bsc (VAL,BINDX,BJNDX,KB,LB,BPNTRB,BPNTRE) implicit none complex(KIND=dp) ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::KB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BJNDX) dummy=LB*LB allocate(DV(KB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,KB DV(i)=counter(BJNDX,i) end do DV(KB+1)=counter(BJNDX,-1) call PNTR(BPNTRB,BPNTRE,KB,BJNDX) call up_order(BJNDX,ORD_RES) call zb_up_order (VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call zb_up_order (VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine zpre_usconv_bco2bsc end module mod_conv_tools SHAR_EOF fi # end of overwriting check if test -f 'dense.f90' then echo shar: will not over-write existing file "'dense.f90'" else cat << "SHAR_EOF" > 'dense.f90' module mod_dense_mat_algos ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : DENSE MATRIX ALGORITHMS FOR BLOCK SPARSE MATRICES ! ********************************************************************** use properties implicit none interface block_mult_vec module procedure iblock_mult_vec module procedure sblock_mult_vec module procedure dblock_mult_vec module procedure cblock_mult_vec module procedure zblock_mult_vec end interface interface block_Z_mult_vec module procedure iblock_Z_mult_vec module procedure sblock_Z_mult_vec module procedure dblock_Z_mult_vec module procedure cblock_Z_mult_vec module procedure zblock_Z_mult_vec end interface interface block_T_mult_vec module procedure iblock_T_mult_vec module procedure sblock_T_mult_vec module procedure dblock_T_mult_vec module procedure cblock_T_mult_vec module procedure zblock_T_mult_vec end interface interface block_H_mult_vec module procedure iblock_H_mult_vec module procedure sblock_H_mult_vec module procedure dblock_H_mult_vec module procedure cblock_H_mult_vec module procedure zblock_H_mult_vec end interface interface invert_left_lower module procedure iinvert_left_lower module procedure sinvert_left_lower module procedure dinvert_left_lower module procedure cinvert_left_lower module procedure zinvert_left_lower end interface interface invert_T_left_lower module procedure iinvert_T_left_lower module procedure sinvert_T_left_lower module procedure dinvert_T_left_lower module procedure cinvert_T_left_lower module procedure zinvert_T_left_lower end interface interface invert_right_upper module procedure iinvert_right_upper module procedure sinvert_right_upper module procedure dinvert_right_upper module procedure cinvert_right_upper module procedure zinvert_right_upper end interface interface invert_T_right_upper module procedure iinvert_T_right_upper module procedure sinvert_T_right_upper module procedure dinvert_T_right_upper module procedure cinvert_T_right_upper module procedure zinvert_T_right_upper end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iblock_mult_vec (A,x,n,y,m,store,ierr) implicit none integer , dimension(:), intent(in) :: A,x integer , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call iblock_r_mult_vec (A,x,n,y,m,ierr) else call iblock_l_mult_vec (A,x,n,y,m,ierr) end if end subroutine iblock_mult_vec ! *** subroutine iblock_Z_mult_vec (A,x,n,y,m,store,ierr) implicit none integer , dimension(:), intent(in) :: A,x integer , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call iblock_r_mult_vec (A, (x),n,y,m,ierr) else call iblock_l_mult_vec (A, (x),n,y,m,ierr) end if y= (y) end subroutine iblock_Z_mult_vec ! *** subroutine iblock_T_mult_vec (A,x,n,y,m,store,ierr) implicit none integer , dimension(:), intent(in) :: A,x integer , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call iblock_l_mult_vec (A,x,n,y,m,ierr) else call iblock_r_mult_vec (A,x,n,y,m,ierr) end if end subroutine iblock_T_mult_vec ! *** subroutine iblock_H_mult_vec (A,x,n,y,m,store,ierr) implicit none integer , dimension(:), intent(in) :: A,x integer , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call iblock_l_mult_vec (A, (x),n,y,m,ierr) else call iblock_r_mult_vec (A, (x),n,y,m,ierr) end if y= (y) end subroutine iblock_H_mult_vec ! *** subroutine iinvert_left_lower (A,x,n,store,ierr) implicit none integer , dimension(:), intent(in) :: A integer , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call iinvert_r_left_lower (A,x,n,ierr) else call iinvert_l_right_upper (A,x,n,ierr) end if end subroutine iinvert_left_lower ! *** subroutine iinvert_T_left_lower (A,x,n,store,ierr) implicit none integer , dimension(:), intent(in) :: A integer , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call iinvert_l_left_lower (A,x,n,ierr) else call iinvert_r_right_upper (A,x,n,ierr) end if end subroutine iinvert_T_left_lower ! *** subroutine iinvert_right_upper (A,x,n,store,ierr) implicit none integer , dimension(:), intent(in) :: A integer , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call iinvert_r_right_upper (A,x,n,ierr) else call iinvert_l_left_lower (A,x,n,ierr) end if end subroutine iinvert_right_upper ! *** subroutine iinvert_T_right_upper (A,x,n,store,ierr) implicit none integer , dimension(:), intent(in) :: A integer , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call iinvert_l_right_upper (A,x,n,ierr) else call iinvert_r_left_lower (A,x,n,ierr) end if end subroutine iinvert_T_right_upper ! *** ! *** ! *** subroutine iblock_r_mult_vec (A,x,n,y,m,ierr) implicit none integer , dimension(:), intent(in) :: A,x integer , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(size(y).ne.m).or.(n*m.ne.size(A))) then return end if do j=1,n y = y + A((j-1)*m+1:j*m) * x(j) end do ierr = 0 end subroutine iblock_r_mult_vec ! *** subroutine iblock_l_mult_vec (A,x,m,y,n,ierr) implicit none intrinsic dot_product integer , dimension(:), intent(in) :: A,x integer , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.m).or.(size(y).ne.n).or.(n*m.ne.size(A))) then return end if do j=1,n y(j) = y(j) + dot_product(A((j-1)*m+1:j*m),x) end do ierr = 0 end subroutine iblock_l_mult_vec ! *** subroutine iinvert_r_left_lower (A,x,n,ierr) !left_lower, stored column-wise implicit none integer , dimension(:), intent(in) :: A integer , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(j+1:n) = x(j+1:n) - x(j) * a((j-1)*n+j+1:j*n) end do ierr = 0 end subroutine iinvert_r_left_lower ! *** subroutine iinvert_l_left_lower (A,x,n,ierr) !left_lower, stored row-wise implicit none intrinsic dot_product integer , dimension(:), intent(in) :: A integer , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 x(j) = x(j) - dot_product(a((j-1)*n+j+1:j*n),x(j+1:n)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine iinvert_l_left_lower ! *** subroutine iinvert_r_right_upper (A,x,n,ierr) implicit none integer , dimension(:), intent(in) :: A integer , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(1:j-1) = x(1:j-1) - x(j) * a((j-1)*n+1:(j-1)*n+j-1) end do ierr = 0 end subroutine iinvert_r_right_upper ! *** subroutine iinvert_l_right_upper (A,x,n,ierr) implicit none integer , dimension(:), intent(in) :: A integer , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n x(j) = x(j) - dot_product(a((j-1)*n+1:(j-1)*n+j-1),x(1:j-1)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine iinvert_l_right_upper ! ********************************************************************** ! ********************************************************************** subroutine sblock_mult_vec (A,x,n,y,m,store,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A,x real(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call sblock_r_mult_vec (A,x,n,y,m,ierr) else call sblock_l_mult_vec (A,x,n,y,m,ierr) end if end subroutine sblock_mult_vec ! *** subroutine sblock_Z_mult_vec (A,x,n,y,m,store,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A,x real(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call sblock_r_mult_vec (A, (x),n,y,m,ierr) else call sblock_l_mult_vec (A, (x),n,y,m,ierr) end if y= (y) end subroutine sblock_Z_mult_vec ! *** subroutine sblock_T_mult_vec (A,x,n,y,m,store,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A,x real(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call sblock_l_mult_vec (A,x,n,y,m,ierr) else call sblock_r_mult_vec (A,x,n,y,m,ierr) end if end subroutine sblock_T_mult_vec ! *** subroutine sblock_H_mult_vec (A,x,n,y,m,store,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A,x real(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call sblock_l_mult_vec (A, (x),n,y,m,ierr) else call sblock_r_mult_vec (A, (x),n,y,m,ierr) end if y= (y) end subroutine sblock_H_mult_vec ! *** subroutine sinvert_left_lower (A,x,n,store,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call sinvert_r_left_lower (A,x,n,ierr) else call sinvert_l_right_upper (A,x,n,ierr) end if end subroutine sinvert_left_lower ! *** subroutine sinvert_T_left_lower (A,x,n,store,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call sinvert_l_left_lower (A,x,n,ierr) else call sinvert_r_right_upper (A,x,n,ierr) end if end subroutine sinvert_T_left_lower ! *** subroutine sinvert_right_upper (A,x,n,store,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call sinvert_r_right_upper (A,x,n,ierr) else call sinvert_l_left_lower (A,x,n,ierr) end if end subroutine sinvert_right_upper ! *** subroutine sinvert_T_right_upper (A,x,n,store,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call sinvert_l_right_upper (A,x,n,ierr) else call sinvert_r_left_lower (A,x,n,ierr) end if end subroutine sinvert_T_right_upper ! *** ! *** ! *** subroutine sblock_r_mult_vec (A,x,n,y,m,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A,x real(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(size(y).ne.m).or.(n*m.ne.size(A))) then return end if do j=1,n y = y + A((j-1)*m+1:j*m) * x(j) end do ierr = 0 end subroutine sblock_r_mult_vec ! *** subroutine sblock_l_mult_vec (A,x,m,y,n,ierr) implicit none intrinsic dot_product real(KIND=sp) , dimension(:), intent(in) :: A,x real(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.m).or.(size(y).ne.n).or.(n*m.ne.size(A))) then return end if do j=1,n y(j) = y(j) + dot_product(A((j-1)*m+1:j*m),x) end do ierr = 0 end subroutine sblock_l_mult_vec ! *** subroutine sinvert_r_left_lower (A,x,n,ierr) !left_lower, stored column-wise implicit none real(KIND=sp) , dimension(:), intent(in) :: A real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(j+1:n) = x(j+1:n) - x(j) * a((j-1)*n+j+1:j*n) end do ierr = 0 end subroutine sinvert_r_left_lower ! *** subroutine sinvert_l_left_lower (A,x,n,ierr) !left_lower, stored row-wise implicit none intrinsic dot_product real(KIND=sp) , dimension(:), intent(in) :: A real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 x(j) = x(j) - dot_product(a((j-1)*n+j+1:j*n),x(j+1:n)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine sinvert_l_left_lower ! *** subroutine sinvert_r_right_upper (A,x,n,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(1:j-1) = x(1:j-1) - x(j) * a((j-1)*n+1:(j-1)*n+j-1) end do ierr = 0 end subroutine sinvert_r_right_upper ! *** subroutine sinvert_l_right_upper (A,x,n,ierr) implicit none real(KIND=sp) , dimension(:), intent(in) :: A real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n x(j) = x(j) - dot_product(a((j-1)*n+1:(j-1)*n+j-1),x(1:j-1)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine sinvert_l_right_upper ! ********************************************************************** ! ********************************************************************** subroutine dblock_mult_vec (A,x,n,y,m,store,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A,x real(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call dblock_r_mult_vec (A,x,n,y,m,ierr) else call dblock_l_mult_vec (A,x,n,y,m,ierr) end if end subroutine dblock_mult_vec ! *** subroutine dblock_Z_mult_vec (A,x,n,y,m,store,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A,x real(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call dblock_r_mult_vec (A, (x),n,y,m,ierr) else call dblock_l_mult_vec (A, (x),n,y,m,ierr) end if y= (y) end subroutine dblock_Z_mult_vec ! *** subroutine dblock_T_mult_vec (A,x,n,y,m,store,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A,x real(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call dblock_l_mult_vec (A,x,n,y,m,ierr) else call dblock_r_mult_vec (A,x,n,y,m,ierr) end if end subroutine dblock_T_mult_vec ! *** subroutine dblock_H_mult_vec (A,x,n,y,m,store,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A,x real(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call dblock_l_mult_vec (A, (x),n,y,m,ierr) else call dblock_r_mult_vec (A, (x),n,y,m,ierr) end if y= (y) end subroutine dblock_H_mult_vec ! *** subroutine dinvert_left_lower (A,x,n,store,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call dinvert_r_left_lower (A,x,n,ierr) else call dinvert_l_right_upper (A,x,n,ierr) end if end subroutine dinvert_left_lower ! *** subroutine dinvert_T_left_lower (A,x,n,store,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call dinvert_l_left_lower (A,x,n,ierr) else call dinvert_r_right_upper (A,x,n,ierr) end if end subroutine dinvert_T_left_lower ! *** subroutine dinvert_right_upper (A,x,n,store,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call dinvert_r_right_upper (A,x,n,ierr) else call dinvert_l_left_lower (A,x,n,ierr) end if end subroutine dinvert_right_upper ! *** subroutine dinvert_T_right_upper (A,x,n,store,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call dinvert_l_right_upper (A,x,n,ierr) else call dinvert_r_left_lower (A,x,n,ierr) end if end subroutine dinvert_T_right_upper ! *** ! *** ! *** subroutine dblock_r_mult_vec (A,x,n,y,m,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A,x real(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(size(y).ne.m).or.(n*m.ne.size(A))) then return end if do j=1,n y = y + A((j-1)*m+1:j*m) * x(j) end do ierr = 0 end subroutine dblock_r_mult_vec ! *** subroutine dblock_l_mult_vec (A,x,m,y,n,ierr) implicit none intrinsic dot_product real(KIND=dp) , dimension(:), intent(in) :: A,x real(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.m).or.(size(y).ne.n).or.(n*m.ne.size(A))) then return end if do j=1,n y(j) = y(j) + dot_product(A((j-1)*m+1:j*m),x) end do ierr = 0 end subroutine dblock_l_mult_vec ! *** subroutine dinvert_r_left_lower (A,x,n,ierr) !left_lower, stored column-wise implicit none real(KIND=dp) , dimension(:), intent(in) :: A real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(j+1:n) = x(j+1:n) - x(j) * a((j-1)*n+j+1:j*n) end do ierr = 0 end subroutine dinvert_r_left_lower ! *** subroutine dinvert_l_left_lower (A,x,n,ierr) !left_lower, stored row-wise implicit none intrinsic dot_product real(KIND=dp) , dimension(:), intent(in) :: A real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 x(j) = x(j) - dot_product(a((j-1)*n+j+1:j*n),x(j+1:n)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine dinvert_l_left_lower ! *** subroutine dinvert_r_right_upper (A,x,n,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(1:j-1) = x(1:j-1) - x(j) * a((j-1)*n+1:(j-1)*n+j-1) end do ierr = 0 end subroutine dinvert_r_right_upper ! *** subroutine dinvert_l_right_upper (A,x,n,ierr) implicit none real(KIND=dp) , dimension(:), intent(in) :: A real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n x(j) = x(j) - dot_product(a((j-1)*n+1:(j-1)*n+j-1),x(1:j-1)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine dinvert_l_right_upper ! ********************************************************************** ! ********************************************************************** subroutine cblock_mult_vec (A,x,n,y,m,store,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A,x complex(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call cblock_r_mult_vec (A,x,n,y,m,ierr) else call cblock_l_mult_vec (A,x,n,y,m,ierr) end if end subroutine cblock_mult_vec ! *** subroutine cblock_Z_mult_vec (A,x,n,y,m,store,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A,x complex(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call cblock_r_mult_vec (A,conjg (x),n,y,m,ierr) else call cblock_l_mult_vec (A,conjg (x),n,y,m,ierr) end if y= conjg (y) end subroutine cblock_Z_mult_vec ! *** subroutine cblock_T_mult_vec (A,x,n,y,m,store,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A,x complex(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call cblock_l_mult_vec (A,x,n,y,m,ierr) else call cblock_r_mult_vec (A,x,n,y,m,ierr) end if end subroutine cblock_T_mult_vec ! *** subroutine cblock_H_mult_vec (A,x,n,y,m,store,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A,x complex(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call cblock_l_mult_vec (A,conjg (x),n,y,m,ierr) else call cblock_r_mult_vec (A,conjg (x),n,y,m,ierr) end if y= conjg (y) end subroutine cblock_H_mult_vec ! *** subroutine cinvert_left_lower (A,x,n,store,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call cinvert_r_left_lower (A,x,n,ierr) else call cinvert_l_right_upper (A,x,n,ierr) end if end subroutine cinvert_left_lower ! *** subroutine cinvert_T_left_lower (A,x,n,store,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call cinvert_l_left_lower (A,x,n,ierr) else call cinvert_r_right_upper (A,x,n,ierr) end if end subroutine cinvert_T_left_lower ! *** subroutine cinvert_right_upper (A,x,n,store,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call cinvert_r_right_upper (A,x,n,ierr) else call cinvert_l_left_lower (A,x,n,ierr) end if end subroutine cinvert_right_upper ! *** subroutine cinvert_T_right_upper (A,x,n,store,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call cinvert_l_right_upper (A,x,n,ierr) else call cinvert_r_left_lower (A,x,n,ierr) end if end subroutine cinvert_T_right_upper ! *** ! *** ! *** subroutine cblock_r_mult_vec (A,x,n,y,m,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A,x complex(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(size(y).ne.m).or.(n*m.ne.size(A))) then return end if do j=1,n y = y + A((j-1)*m+1:j*m) * x(j) end do ierr = 0 end subroutine cblock_r_mult_vec ! *** subroutine cblock_l_mult_vec (A,x,m,y,n,ierr) implicit none intrinsic dot_product complex(KIND=sp) , dimension(:), intent(in) :: A,x complex(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.m).or.(size(y).ne.n).or.(n*m.ne.size(A))) then return end if do j=1,n y(j) = y(j) + dot_product(A((j-1)*m+1:j*m),x) end do ierr = 0 end subroutine cblock_l_mult_vec ! *** subroutine cinvert_r_left_lower (A,x,n,ierr) !left_lower, stored column-wise implicit none complex(KIND=sp) , dimension(:), intent(in) :: A complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(j+1:n) = x(j+1:n) - x(j) * a((j-1)*n+j+1:j*n) end do ierr = 0 end subroutine cinvert_r_left_lower ! *** subroutine cinvert_l_left_lower (A,x,n,ierr) !left_lower, stored row-wise implicit none intrinsic dot_product complex(KIND=sp) , dimension(:), intent(in) :: A complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 x(j) = x(j) - dot_product(a((j-1)*n+j+1:j*n),x(j+1:n)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine cinvert_l_left_lower ! *** subroutine cinvert_r_right_upper (A,x,n,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(1:j-1) = x(1:j-1) - x(j) * a((j-1)*n+1:(j-1)*n+j-1) end do ierr = 0 end subroutine cinvert_r_right_upper ! *** subroutine cinvert_l_right_upper (A,x,n,ierr) implicit none complex(KIND=sp) , dimension(:), intent(in) :: A complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n x(j) = x(j) - dot_product(a((j-1)*n+1:(j-1)*n+j-1),x(1:j-1)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine cinvert_l_right_upper ! ********************************************************************** ! ********************************************************************** subroutine zblock_mult_vec (A,x,n,y,m,store,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A,x complex(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call zblock_r_mult_vec (A,x,n,y,m,ierr) else call zblock_l_mult_vec (A,x,n,y,m,ierr) end if end subroutine zblock_mult_vec ! *** subroutine zblock_Z_mult_vec (A,x,n,y,m,store,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A,x complex(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call zblock_r_mult_vec (A,conjg (x),n,y,m,ierr) else call zblock_l_mult_vec (A,conjg (x),n,y,m,ierr) end if y= conjg (y) end subroutine zblock_Z_mult_vec ! *** subroutine zblock_T_mult_vec (A,x,n,y,m,store,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A,x complex(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call zblock_l_mult_vec (A,x,n,y,m,ierr) else call zblock_r_mult_vec (A,x,n,y,m,ierr) end if end subroutine zblock_T_mult_vec ! *** subroutine zblock_H_mult_vec (A,x,n,y,m,store,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A,x complex(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call zblock_l_mult_vec (A,conjg (x),n,y,m,ierr) else call zblock_r_mult_vec (A,conjg (x),n,y,m,ierr) end if y= conjg (y) end subroutine zblock_H_mult_vec ! *** subroutine zinvert_left_lower (A,x,n,store,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call zinvert_r_left_lower (A,x,n,ierr) else call zinvert_l_right_upper (A,x,n,ierr) end if end subroutine zinvert_left_lower ! *** subroutine zinvert_T_left_lower (A,x,n,store,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call zinvert_l_left_lower (A,x,n,ierr) else call zinvert_r_right_upper (A,x,n,ierr) end if end subroutine zinvert_T_left_lower ! *** subroutine zinvert_right_upper (A,x,n,store,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call zinvert_r_right_upper (A,x,n,ierr) else call zinvert_l_left_lower (A,x,n,ierr) end if end subroutine zinvert_right_upper ! *** subroutine zinvert_T_right_upper (A,x,n,store,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call zinvert_l_right_upper (A,x,n,ierr) else call zinvert_r_left_lower (A,x,n,ierr) end if end subroutine zinvert_T_right_upper ! *** ! *** ! *** subroutine zblock_r_mult_vec (A,x,n,y,m,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A,x complex(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(size(y).ne.m).or.(n*m.ne.size(A))) then return end if do j=1,n y = y + A((j-1)*m+1:j*m) * x(j) end do ierr = 0 end subroutine zblock_r_mult_vec ! *** subroutine zblock_l_mult_vec (A,x,m,y,n,ierr) implicit none intrinsic dot_product complex(KIND=dp) , dimension(:), intent(in) :: A,x complex(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.m).or.(size(y).ne.n).or.(n*m.ne.size(A))) then return end if do j=1,n y(j) = y(j) + dot_product(A((j-1)*m+1:j*m),x) end do ierr = 0 end subroutine zblock_l_mult_vec ! *** subroutine zinvert_r_left_lower (A,x,n,ierr) !left_lower, stored column-wise implicit none complex(KIND=dp) , dimension(:), intent(in) :: A complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(j+1:n) = x(j+1:n) - x(j) * a((j-1)*n+j+1:j*n) end do ierr = 0 end subroutine zinvert_r_left_lower ! *** subroutine zinvert_l_left_lower (A,x,n,ierr) !left_lower, stored row-wise implicit none intrinsic dot_product complex(KIND=dp) , dimension(:), intent(in) :: A complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 x(j) = x(j) - dot_product(a((j-1)*n+j+1:j*n),x(j+1:n)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine zinvert_l_left_lower ! *** subroutine zinvert_r_right_upper (A,x,n,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(1:j-1) = x(1:j-1) - x(j) * a((j-1)*n+1:(j-1)*n+j-1) end do ierr = 0 end subroutine zinvert_r_right_upper ! *** subroutine zinvert_l_right_upper (A,x,n,ierr) implicit none complex(KIND=dp) , dimension(:), intent(in) :: A complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n x(j) = x(j) - dot_product(a((j-1)*n+1:(j-1)*n+j-1),x(1:j-1)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine zinvert_l_right_upper ! ********************************************************************** ! ********************************************************************** end module mod_dense_mat_algos SHAR_EOF fi # end of overwriting check if test -f 'hash.f90' then echo shar: will not over-write existing file "'hash.f90'" else cat << "SHAR_EOF" > 'hash.f90' module mod_hash use blas_sparse_namedconstants ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 3.1.2002 ! ! Description : A hash table for 'COO' and 'BCO' triangular solver ! ********************************************************************** implicit none type capsule integer :: jndx,val_pos type(capsule), pointer :: pntr end type capsule type cappntr type(capsule), pointer :: pntr end type cappntr type(capsule), dimension(:), target, allocatable :: hash type(cappntr), dimension(:), allocatable :: hash_top contains subroutine setup_hash(n,ierr) implicit none integer, intent(in) :: n integer, intent(out) :: ierr integer :: i ierr = -1 allocate(hash(n),STAT=ierr) if (ierr.ne.0) then ierr=blas_error_memalloc return end if allocate(hash_top(n),STAT=ierr) if (ierr.ne.0) then ierr=blas_error_memalloc return end if do i = 1,n nullify(hash(i)%pntr) hash%jndx = -1 hash%val_pos = -1 hash_top(i)%pntr => hash(i) end do ierr = 0 end subroutine setup_hash subroutine new_capsule_main(indx,jndx,pos,ierr) implicit none integer, intent(in) :: indx,jndx,pos integer, intent(out) :: ierr type(capsule), pointer :: cap ierr = -1 if ((indx.lt.lbound(hash,1)).or.(indx.gt.ubound(hash,1))) then return end if if(indx.eq.jndx) then hash(indx)%val_pos = pos hash(indx)%jndx = jndx else allocate(cap,STAT=ierr) if (ierr.ne.0) then ierr=blas_error_memalloc return end if cap%val_pos = pos cap%jndx = jndx nullify(cap%pntr) hash_top(indx)%pntr%pntr => cap hash_top(indx)%pntr => cap end if ierr = 0 end subroutine new_capsule_main subroutine print_hash() implicit none integer :: i type(capsule), pointer :: dummy do i=lbound(hash,1),ubound(hash,1) write(*,*)'print hash(',i,') ' dummy => hash(i) do while(associated(dummy%pntr)) write(*,*)'jndx : ', dummy%jndx write(*,*)'val_pos : ',dummy%val_pos dummy => dummy%pntr end do write(*,*)'jndx : ', dummy%jndx write(*,*)'val_pos : ',dummy%val_pos end do end subroutine print_hash subroutine remove_hash(ierr) implicit none integer, intent(out) :: ierr integer :: i ierr = -1 do i=lbound(hash,1),ubound(hash,1) do while(.not.associated(hash_top(i)%pntr,hash(i))) call del_capsule(i,ierr) if (ierr.ne.0) then ierr=blas_error_memdeloc return end if end do end do deallocate(hash,hash_top,STAT=ierr) if (ierr.ne.0) then ierr=blas_error_memdeloc return end if end subroutine remove_hash subroutine del_capsule(nmb,ierr) implicit none integer, intent(in) :: nmb integer, intent(out) :: ierr type(capsule), pointer :: dummy dummy => hash(nmb) if (associated(dummy,hash_top(nmb)%pntr)) then ierr = -1 return end if do while(.not.associated(dummy%pntr,hash_top(nmb)%pntr)) dummy => dummy%pntr end do hash_top(nmb)%pntr => dummy deallocate(dummy%pntr,STAT=ierr) if(ierr.ne.0) then ierr=blas_error_memdeloc return end if end subroutine del_capsule end module mod_hash SHAR_EOF fi # end of overwriting check if test -f 'info.f90' then echo shar: will not over-write existing file "'info.f90'" else cat << "SHAR_EOF" > 'info.f90' module mod_info ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : FOR DEBUGGING ONLY !!! ! "print" displays data for given handle number ! ********************************************************************** use representation_of_data use properties implicit none contains subroutine print(nmb,ierr) implicit none intrinsic modulo integer, intent(in) :: nmb integer, intent(out) :: ierr type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer :: rest,base,copy,nnz,rowdim,coldim character :: style,diag,type,part,store rest = modulo(nmb,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,nmb,ierr) if (ierr.ne.0) then write(*,*) '***********************************' write(*,*) 'No data for no. ',nmb,' available !' write(*,*) '***********************************' return end if write(*,*) '***********************************' write(*,*) 'Matrix no. ', nmb write(*,*) 'number of rows : ', isp_data %M write(*,*) 'number of columns : ', isp_data %K write(*,*) 'Storage : ', isp_data %FIDA write(*,*) 'A : ', isp_data %A write(*,*) 'IA1 : ', isp_data %IA1 write(*,*) 'IA2 : ', isp_data %IA2 write(*,*) '***********************************' call get_descra(isp_data %DESCRA,'a',part,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix part accessed : ',part end if call get_descra(isp_data %DESCRA,'b',style,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Index style : ',style end if call get_descra(isp_data %DESCRA,'d',diag,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Unity-diagonal : ',diag end if call get_descra(isp_data %DESCRA,'f',store,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block-internal storage : ',store end if call get_descra(isp_data %DESCRA,'t',type,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix type : ',type end if call get_infoa(isp_data %INFOA,'b',base,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Indices start at : ',base end if call get_infoa(isp_data %INFOA,'c',copy,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix is copy of original data : ',copy end if call get_infoa(isp_data %INFOA,'n',nnz,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'number of non-zero(-block)s : ',nnz end if call get_infoa(isp_data %INFOA,'d',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) row dim of block : ',rowdim end if call get_infoa(isp_data %INFOA,'e',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) col dim of block : ',coldim end if call get_infoa(isp_data %INFOA,'f',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : row-dim in blocks : ',rowdim end if call get_infoa(isp_data %INFOA,'g',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : col-dim in blocks : ',coldim end if write(*,*) '***********************************' ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,nmb,ierr) if (ierr.ne.0) then write(*,*) '***********************************' write(*,*) 'No data for no. ',nmb,' available !' write(*,*) '***********************************' return end if write(*,*) '***********************************' write(*,*) 'Matrix no. ', nmb write(*,*) 'number of rows : ', ssp_data %M write(*,*) 'number of columns : ', ssp_data %K write(*,*) 'Storage : ', ssp_data %FIDA write(*,*) 'A : ', ssp_data %A write(*,*) 'IA1 : ', ssp_data %IA1 write(*,*) 'IA2 : ', ssp_data %IA2 write(*,*) '***********************************' call get_descra(ssp_data %DESCRA,'a',part,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix part accessed : ',part end if call get_descra(ssp_data %DESCRA,'b',style,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Index style : ',style end if call get_descra(ssp_data %DESCRA,'d',diag,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Unity-diagonal : ',diag end if call get_descra(ssp_data %DESCRA,'f',store,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block-internal storage : ',store end if call get_descra(ssp_data %DESCRA,'t',type,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix type : ',type end if call get_infoa(ssp_data %INFOA,'b',base,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Indices start at : ',base end if call get_infoa(ssp_data %INFOA,'c',copy,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix is copy of original data : ',copy end if call get_infoa(ssp_data %INFOA,'n',nnz,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'number of non-zero(-block)s : ',nnz end if call get_infoa(ssp_data %INFOA,'d',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) row dim of block : ',rowdim end if call get_infoa(ssp_data %INFOA,'e',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) col dim of block : ',coldim end if call get_infoa(ssp_data %INFOA,'f',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : row-dim in blocks : ',rowdim end if call get_infoa(ssp_data %INFOA,'g',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : col-dim in blocks : ',coldim end if write(*,*) '***********************************' ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,nmb,ierr) if (ierr.ne.0) then write(*,*) '***********************************' write(*,*) 'No data for no. ',nmb,' available !' write(*,*) '***********************************' return end if write(*,*) '***********************************' write(*,*) 'Matrix no. ', nmb write(*,*) 'number of rows : ', dsp_data %M write(*,*) 'number of columns : ', dsp_data %K write(*,*) 'Storage : ', dsp_data %FIDA write(*,*) 'A : ', dsp_data %A write(*,*) 'IA1 : ', dsp_data %IA1 write(*,*) 'IA2 : ', dsp_data %IA2 write(*,*) '***********************************' call get_descra(dsp_data %DESCRA,'a',part,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix part accessed : ',part end if call get_descra(dsp_data %DESCRA,'b',style,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Index style : ',style end if call get_descra(dsp_data %DESCRA,'d',diag,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Unity-diagonal : ',diag end if call get_descra(dsp_data %DESCRA,'f',store,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block-internal storage : ',store end if call get_descra(dsp_data %DESCRA,'t',type,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix type : ',type end if call get_infoa(dsp_data %INFOA,'b',base,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Indices start at : ',base end if call get_infoa(dsp_data %INFOA,'c',copy,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix is copy of original data : ',copy end if call get_infoa(dsp_data %INFOA,'n',nnz,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'number of non-zero(-block)s : ',nnz end if call get_infoa(dsp_data %INFOA,'d',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) row dim of block : ',rowdim end if call get_infoa(dsp_data %INFOA,'e',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) col dim of block : ',coldim end if call get_infoa(dsp_data %INFOA,'f',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : row-dim in blocks : ',rowdim end if call get_infoa(dsp_data %INFOA,'g',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : col-dim in blocks : ',coldim end if write(*,*) '***********************************' ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,nmb,ierr) if (ierr.ne.0) then write(*,*) '***********************************' write(*,*) 'No data for no. ',nmb,' available !' write(*,*) '***********************************' return end if write(*,*) '***********************************' write(*,*) 'Matrix no. ', nmb write(*,*) 'number of rows : ', csp_data %M write(*,*) 'number of columns : ', csp_data %K write(*,*) 'Storage : ', csp_data %FIDA write(*,*) 'A : ', csp_data %A write(*,*) 'IA1 : ', csp_data %IA1 write(*,*) 'IA2 : ', csp_data %IA2 write(*,*) '***********************************' call get_descra(csp_data %DESCRA,'a',part,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix part accessed : ',part end if call get_descra(csp_data %DESCRA,'b',style,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Index style : ',style end if call get_descra(csp_data %DESCRA,'d',diag,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Unity-diagonal : ',diag end if call get_descra(csp_data %DESCRA,'f',store,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block-internal storage : ',store end if call get_descra(csp_data %DESCRA,'t',type,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix type : ',type end if call get_infoa(csp_data %INFOA,'b',base,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Indices start at : ',base end if call get_infoa(csp_data %INFOA,'c',copy,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix is copy of original data : ',copy end if call get_infoa(csp_data %INFOA,'n',nnz,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'number of non-zero(-block)s : ',nnz end if call get_infoa(csp_data %INFOA,'d',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) row dim of block : ',rowdim end if call get_infoa(csp_data %INFOA,'e',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) col dim of block : ',coldim end if call get_infoa(csp_data %INFOA,'f',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : row-dim in blocks : ',rowdim end if call get_infoa(csp_data %INFOA,'g',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : col-dim in blocks : ',coldim end if write(*,*) '***********************************' ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,nmb,ierr) if (ierr.ne.0) then write(*,*) '***********************************' write(*,*) 'No data for no. ',nmb,' available !' write(*,*) '***********************************' return end if write(*,*) '***********************************' write(*,*) 'Matrix no. ', nmb write(*,*) 'number of rows : ', zsp_data %M write(*,*) 'number of columns : ', zsp_data %K write(*,*) 'Storage : ', zsp_data %FIDA write(*,*) 'A : ', zsp_data %A write(*,*) 'IA1 : ', zsp_data %IA1 write(*,*) 'IA2 : ', zsp_data %IA2 write(*,*) '***********************************' call get_descra(zsp_data %DESCRA,'a',part,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix part accessed : ',part end if call get_descra(zsp_data %DESCRA,'b',style,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Index style : ',style end if call get_descra(zsp_data %DESCRA,'d',diag,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Unity-diagonal : ',diag end if call get_descra(zsp_data %DESCRA,'f',store,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block-internal storage : ',store end if call get_descra(zsp_data %DESCRA,'t',type,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix type : ',type end if call get_infoa(zsp_data %INFOA,'b',base,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Indices start at : ',base end if call get_infoa(zsp_data %INFOA,'c',copy,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix is copy of original data : ',copy end if call get_infoa(zsp_data %INFOA,'n',nnz,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'number of non-zero(-block)s : ',nnz end if call get_infoa(zsp_data %INFOA,'d',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) row dim of block : ',rowdim end if call get_infoa(zsp_data %INFOA,'e',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) col dim of block : ',coldim end if call get_infoa(zsp_data %INFOA,'f',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : row-dim in blocks : ',rowdim end if call get_infoa(zsp_data %INFOA,'g',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : col-dim in blocks : ',coldim end if write(*,*) '***********************************' ! ********************************************************************** case default write(*,*) 'Wrong matrix type !' ierr = -1 end select end subroutine print end module mod_info SHAR_EOF fi # end of overwriting check if test -f 'link.f90' then echo shar: will not over-write existing file "'link.f90'" else cat << "SHAR_EOF" > 'link.f90' module representation_of_data ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : THE PRINCIPAL DATA STRUCTURE ! Matrix data is stored in nodes of a linked list ! Node number is the handle number ! new: creates new node WITHOUT initialization ! del: frees unused memory, does NOT care if there ! is other memory that should be freed first ! accessdata: given a handle number, it returns a ! pointer to the matrix inside the relevant node ! ********************************************************************** use types use properties implicit none interface accessdata module procedure accessdata_isp module procedure accessdata_ssp module procedure accessdata_dsp module procedure accessdata_csp module procedure accessdata_zsp end interface type isp_linknode type(ispmat) :: contents integer :: number type(isp_linknode), pointer :: pntr end type isp_linknode type ssp_linknode type(sspmat) :: contents integer :: number type(ssp_linknode), pointer :: pntr end type ssp_linknode type dsp_linknode type(dspmat) :: contents integer :: number type(dsp_linknode), pointer :: pntr end type dsp_linknode type csp_linknode type(cspmat) :: contents integer :: number type(csp_linknode), pointer :: pntr end type csp_linknode type zsp_linknode type(zspmat) :: contents integer :: number type(zsp_linknode), pointer :: pntr end type zsp_linknode type(isp_linknode), pointer,SAVE,PRIVATE :: isp_first, isp_last type(ssp_linknode), pointer,SAVE,PRIVATE :: ssp_first, ssp_last type(dsp_linknode), pointer,SAVE,PRIVATE :: dsp_first, dsp_last type(csp_linknode), pointer,SAVE,PRIVATE :: csp_first, csp_last type(zsp_linknode), pointer,SAVE,PRIVATE :: zsp_first, zsp_last logical,SAVE,PRIVATE :: isp_init = .FALSE. logical,SAVE,PRIVATE :: ssp_init = .FALSE. logical,SAVE,PRIVATE :: dsp_init = .FALSE. logical,SAVE,PRIVATE :: csp_init = .FALSE. logical,SAVE,PRIVATE :: zsp_init = .FALSE. contains ! ********************************************************************** ! ********************************************************************** ! *** Allocate new memory subroutine new_isp (nmb,ierr) integer, intent(out) :: nmb,ierr type(isp_linknode ), pointer :: help if(.not. isp_init ) then nullify(isp_first ) isp_init = .TRUE. endif if (.not.associated(isp_first )) then allocate(isp_first ,STAT=ierr) isp_first %number = ISP_MATRIX nullify(isp_first %pntr) isp_last => isp_first else allocate(help,STAT=ierr) isp_last %pntr => help help%number = isp_last %number + no_of_types nullify(help%pntr) isp_last => help end if nullify(isp_last %contents%A,isp_last %contents%IA1,& isp_last %contents%IA2,isp_last %contents%PB,& isp_last %contents%PE,isp_last %contents%BP1,& isp_last %contents%BP2) isp_last %contents%FIDA ='' isp_last %contents%DESCRA ='' isp_last %contents%INFOA = 0 nmb = isp_last %number end subroutine new_isp ! *** Deallocate unused memory subroutine del_isp (nmb,ierr) type(isp_linknode ), pointer :: help,help2 integer, intent(in) :: nmb integer, intent(out) :: ierr ierr = -1 if (isp_first %number.eq.nmb) then ierr=0 if (associated(isp_first ,isp_last )) then deallocate(isp_first ) nullify(isp_first ,isp_last ) else help2 => isp_first %pntr deallocate(isp_first ) isp_first => help2 end if else help => isp_first do while((ierr.eq.-1).and.(associated(help%pntr%pntr))) if (help%pntr%number.eq.nmb) then help2 => help%pntr help%pntr => help%pntr%pntr deallocate(help2) ierr = 0 else help => help%pntr end if end do if((ierr.eq.-1).and.(help%pntr%number.eq.nmb)) then ierr = 0 help2 => help%pntr isp_last => help nullify(isp_last %pntr) deallocate(help2) end if end if end subroutine del_isp ! *** access contents for given number nmb subroutine accessdata_isp (dspmtx,nmb,ierr) type(ispmat ), pointer :: dspmtx integer, intent(in) :: nmb integer, intent(out) :: ierr type(isp_linknode ), pointer :: isp_handle ierr = -1 isp_handle => isp_first do while((isp_handle %number.ne.nmb).and.& (associated(isp_handle %pntr))) isp_handle => isp_handle %pntr end do if (isp_handle %number.eq.nmb) then ierr = 0 dspmtx => isp_handle %contents else nullify(dspmtx) end if end subroutine accessdata_isp ! ********************************************************************** ! ********************************************************************** ! *** Allocate new memory subroutine new_ssp (nmb,ierr) integer, intent(out) :: nmb,ierr type(ssp_linknode ), pointer :: help if(.not. ssp_init ) then nullify(ssp_first ) ssp_init = .TRUE. endif if (.not.associated(ssp_first )) then allocate(ssp_first ,STAT=ierr) ssp_first %number = SSP_MATRIX nullify(ssp_first %pntr) ssp_last => ssp_first else allocate(help,STAT=ierr) ssp_last %pntr => help help%number = ssp_last %number + no_of_types nullify(help%pntr) ssp_last => help end if nullify(ssp_last %contents%A,ssp_last %contents%IA1,& ssp_last %contents%IA2,ssp_last %contents%PB,& ssp_last %contents%PE,ssp_last %contents%BP1,& ssp_last %contents%BP2) ssp_last %contents%FIDA ='' ssp_last %contents%DESCRA ='' ssp_last %contents%INFOA = 0 nmb = ssp_last %number end subroutine new_ssp ! *** Deallocate unused memory subroutine del_ssp (nmb,ierr) type(ssp_linknode ), pointer :: help,help2 integer, intent(in) :: nmb integer, intent(out) :: ierr ierr = -1 if (ssp_first %number.eq.nmb) then ierr=0 if (associated(ssp_first ,ssp_last )) then deallocate(ssp_first ) nullify(ssp_first ,ssp_last ) else help2 => ssp_first %pntr deallocate(ssp_first ) ssp_first => help2 end if else help => ssp_first do while((ierr.eq.-1).and.(associated(help%pntr%pntr))) if (help%pntr%number.eq.nmb) then help2 => help%pntr help%pntr => help%pntr%pntr deallocate(help2) ierr = 0 else help => help%pntr end if end do if((ierr.eq.-1).and.(help%pntr%number.eq.nmb)) then ierr = 0 help2 => help%pntr ssp_last => help nullify(ssp_last %pntr) deallocate(help2) end if end if end subroutine del_ssp ! *** access contents for given number nmb subroutine accessdata_ssp (dspmtx,nmb,ierr) type(sspmat ), pointer :: dspmtx integer, intent(in) :: nmb integer, intent(out) :: ierr type(ssp_linknode ), pointer :: ssp_handle ierr = -1 ssp_handle => ssp_first do while((ssp_handle %number.ne.nmb).and.& (associated(ssp_handle %pntr))) ssp_handle => ssp_handle %pntr end do if (ssp_handle %number.eq.nmb) then ierr = 0 dspmtx => ssp_handle %contents else nullify(dspmtx) end if end subroutine accessdata_ssp ! ********************************************************************** ! ********************************************************************** ! *** Allocate new memory subroutine new_dsp (nmb,ierr) integer, intent(out) :: nmb,ierr type(dsp_linknode ), pointer :: help if(.not. dsp_init ) then nullify(dsp_first ) dsp_init = .TRUE. endif if (.not.associated(dsp_first )) then allocate(dsp_first ,STAT=ierr) dsp_first %number = DSP_MATRIX nullify(dsp_first %pntr) dsp_last => dsp_first else allocate(help,STAT=ierr) dsp_last %pntr => help help%number = dsp_last %number + no_of_types nullify(help%pntr) dsp_last => help end if nullify(dsp_last %contents%A,dsp_last %contents%IA1,& dsp_last %contents%IA2,dsp_last %contents%PB,& dsp_last %contents%PE,dsp_last %contents%BP1,& dsp_last %contents%BP2) dsp_last %contents%FIDA ='' dsp_last %contents%DESCRA ='' dsp_last %contents%INFOA = 0 nmb = dsp_last %number end subroutine new_dsp ! *** Deallocate unused memory subroutine del_dsp (nmb,ierr) type(dsp_linknode ), pointer :: help,help2 integer, intent(in) :: nmb integer, intent(out) :: ierr ierr = -1 if (dsp_first %number.eq.nmb) then ierr=0 if (associated(dsp_first ,dsp_last )) then deallocate(dsp_first ) nullify(dsp_first ,dsp_last ) else help2 => dsp_first %pntr deallocate(dsp_first ) dsp_first => help2 end if else help => dsp_first do while((ierr.eq.-1).and.(associated(help%pntr%pntr))) if (help%pntr%number.eq.nmb) then help2 => help%pntr help%pntr => help%pntr%pntr deallocate(help2) ierr = 0 else help => help%pntr end if end do if((ierr.eq.-1).and.(help%pntr%number.eq.nmb)) then ierr = 0 help2 => help%pntr dsp_last => help nullify(dsp_last %pntr) deallocate(help2) end if end if end subroutine del_dsp ! *** access contents for given number nmb subroutine accessdata_dsp (dspmtx,nmb,ierr) type(dspmat ), pointer :: dspmtx integer, intent(in) :: nmb integer, intent(out) :: ierr type(dsp_linknode ), pointer :: dsp_handle ierr = -1 dsp_handle => dsp_first do while((dsp_handle %number.ne.nmb).and.& (associated(dsp_handle %pntr))) dsp_handle => dsp_handle %pntr end do if (dsp_handle %number.eq.nmb) then ierr = 0 dspmtx => dsp_handle %contents else nullify(dspmtx) end if end subroutine accessdata_dsp ! ********************************************************************** ! ********************************************************************** ! *** Allocate new memory subroutine new_csp (nmb,ierr) integer, intent(out) :: nmb,ierr type(csp_linknode ), pointer :: help if(.not. csp_init ) then nullify(csp_first ) csp_init = .TRUE. endif if (.not.associated(csp_first )) then allocate(csp_first ,STAT=ierr) csp_first %number = CSP_MATRIX nullify(csp_first %pntr) csp_last => csp_first else allocate(help,STAT=ierr) csp_last %pntr => help help%number = csp_last %number + no_of_types nullify(help%pntr) csp_last => help end if nullify(csp_last %contents%A,csp_last %contents%IA1,& csp_last %contents%IA2,csp_last %contents%PB,& csp_last %contents%PE,csp_last %contents%BP1,& csp_last %contents%BP2) csp_last %contents%FIDA ='' csp_last %contents%DESCRA ='' csp_last %contents%INFOA = 0 nmb = csp_last %number end subroutine new_csp ! *** Deallocate unused memory subroutine del_csp (nmb,ierr) type(csp_linknode ), pointer :: help,help2 integer, intent(in) :: nmb integer, intent(out) :: ierr ierr = -1 if (csp_first %number.eq.nmb) then ierr=0 if (associated(csp_first ,csp_last )) then deallocate(csp_first ) nullify(csp_first ,csp_last ) else help2 => csp_first %pntr deallocate(csp_first ) csp_first => help2 end if else help => csp_first do while((ierr.eq.-1).and.(associated(help%pntr%pntr))) if (help%pntr%number.eq.nmb) then help2 => help%pntr help%pntr => help%pntr%pntr deallocate(help2) ierr = 0 else help => help%pntr end if end do if((ierr.eq.-1).and.(help%pntr%number.eq.nmb)) then ierr = 0 help2 => help%pntr csp_last => help nullify(csp_last %pntr) deallocate(help2) end if end if end subroutine del_csp ! *** access contents for given number nmb subroutine accessdata_csp (dspmtx,nmb,ierr) type(cspmat ), pointer :: dspmtx integer, intent(in) :: nmb integer, intent(out) :: ierr type(csp_linknode ), pointer :: csp_handle ierr = -1 csp_handle => csp_first do while((csp_handle %number.ne.nmb).and.& (associated(csp_handle %pntr))) csp_handle => csp_handle %pntr end do if (csp_handle %number.eq.nmb) then ierr = 0 dspmtx => csp_handle %contents else nullify(dspmtx) end if end subroutine accessdata_csp ! ********************************************************************** ! ********************************************************************** ! *** Allocate new memory subroutine new_zsp (nmb,ierr) integer, intent(out) :: nmb,ierr type(zsp_linknode ), pointer :: help if(.not. zsp_init ) then nullify(zsp_first ) zsp_init = .TRUE. endif if (.not.associated(zsp_first )) then allocate(zsp_first ,STAT=ierr) zsp_first %number = ZSP_MATRIX nullify(zsp_first %pntr) zsp_last => zsp_first else allocate(help,STAT=ierr) zsp_last %pntr => help help%number = zsp_last %number + no_of_types nullify(help%pntr) zsp_last => help end if nullify(zsp_last %contents%A,zsp_last %contents%IA1,& zsp_last %contents%IA2,zsp_last %contents%PB,& zsp_last %contents%PE,zsp_last %contents%BP1,& zsp_last %contents%BP2) zsp_last %contents%FIDA ='' zsp_last %contents%DESCRA ='' zsp_last %contents%INFOA = 0 nmb = zsp_last %number end subroutine new_zsp ! *** Deallocate unused memory subroutine del_zsp (nmb,ierr) type(zsp_linknode ), pointer :: help,help2 integer, intent(in) :: nmb integer, intent(out) :: ierr ierr = -1 if (zsp_first %number.eq.nmb) then ierr=0 if (associated(zsp_first ,zsp_last )) then deallocate(zsp_first ) nullify(zsp_first ,zsp_last ) else help2 => zsp_first %pntr deallocate(zsp_first ) zsp_first => help2 end if else help => zsp_first do while((ierr.eq.-1).and.(associated(help%pntr%pntr))) if (help%pntr%number.eq.nmb) then help2 => help%pntr help%pntr => help%pntr%pntr deallocate(help2) ierr = 0 else help => help%pntr end if end do if((ierr.eq.-1).and.(help%pntr%number.eq.nmb)) then ierr = 0 help2 => help%pntr zsp_last => help nullify(zsp_last %pntr) deallocate(help2) end if end if end subroutine del_zsp ! *** access contents for given number nmb subroutine accessdata_zsp (dspmtx,nmb,ierr) type(zspmat ), pointer :: dspmtx integer, intent(in) :: nmb integer, intent(out) :: ierr type(zsp_linknode ), pointer :: zsp_handle ierr = -1 zsp_handle => zsp_first do while((zsp_handle %number.ne.nmb).and.& (associated(zsp_handle %pntr))) zsp_handle => zsp_handle %pntr end do if (zsp_handle %number.eq.nmb) then ierr = 0 dspmtx => zsp_handle %contents else nullify(dspmtx) end if end subroutine accessdata_zsp ! ********************************************************************** ! ********************************************************************** end module representation_of_data SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bco.f90' then echo shar: will not over-write existing file "'lmbv_bco.f90'" else cat << "SHAR_EOF" > 'lmbv_bco.f90' module mod_lmbv_bco ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BCO'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_bco module procedure ilmbv_bco module procedure slmbv_bco module procedure dlmbv_bco module procedure clmbv_bco module procedure zlmbv_bco end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_bco (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine ilmbv_bco ! ********************************************************************** ! ********************************************************************** subroutine slmbv_bco (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0e0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine slmbv_bco ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_bco (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0d0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine dlmbv_bco ! ********************************************************************** ! ********************************************************************** subroutine clmbv_bco (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine clmbv_bco ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_bco (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine zlmbv_bco ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_bco SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bdi.f90' then echo shar: will not over-write existing file "'lmbv_bdi.f90'" else cat << "SHAR_EOF" > 'lmbv_bdi.f90' module mod_lmbv_bdi ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BDI'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_bdi module procedure ilmbv_bdi module procedure slmbv_bdi module procedure dlmbv_bdi module procedure clmbv_bdi module procedure zlmbv_bdi end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_bdi (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine ilmbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine slmbv_bdi (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0e0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine slmbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_bdi (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0d0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine dlmbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine clmbv_bdi (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine clmbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_bdi (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine zlmbv_bdi ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_bdi SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bsc.f90' then echo shar: will not over-write existing file "'lmbv_bsc.f90'" else cat << "SHAR_EOF" > 'lmbv_bsc.f90' module mod_lmbv_bsc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BSC'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_bsc module procedure ilmbv_bsc module procedure slmbv_bsc module procedure dlmbv_bsc module procedure clmbv_bsc module procedure zlmbv_bsc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_bsc (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine ilmbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine slmbv_bsc (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0e0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine slmbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_bsc (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0d0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine dlmbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine clmbv_bsc (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine clmbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_bsc (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zlmbv_bsc ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_bsc SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bsr.f90' then echo shar: will not over-write existing file "'lmbv_bsr.f90'" else cat << "SHAR_EOF" > 'lmbv_bsr.f90' module mod_lmbv_bsr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BSR'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_bsr module procedure ilmbv_bsr module procedure slmbv_bsr module procedure dlmbv_bsr module procedure clmbv_bsr module procedure zlmbv_bsr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_bsr (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine ilmbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine slmbv_bsr (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0e0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine slmbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_bsr (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0d0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine dlmbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine clmbv_bsr (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine clmbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_bsr (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zlmbv_bsr ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_bsr SHAR_EOF fi # end of overwriting check if test -f 'lmbv_coo.f90' then echo shar: will not over-write existing file "'lmbv_coo.f90'" else cat << "SHAR_EOF" > 'lmbv_coo.f90' module mod_lmbv_coo ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH TRANSPOSE IN 'COO'-STORAGE ! lmbv = Left Multiplication By Vector: y^T = x^TA ! ********************************************************************** use representation_of_data use properties implicit none interface lmbv_coo module procedure ilmbv_coo module procedure slmbv_coo module procedure dlmbv_coo module procedure clmbv_coo module procedure zlmbv_coo end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_coo (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,i,ofs character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end do ierr = 0 end if end subroutine ilmbv_coo ! ********************************************************************** ! ********************************************************************** subroutine slmbv_coo (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,i,ofs character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end do ierr = 0 end if end subroutine slmbv_coo ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_coo (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,i,ofs character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end do ierr = 0 end if end subroutine dlmbv_coo ! ********************************************************************** ! ********************************************************************** subroutine clmbv_coo (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,i,ofs character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + conjg (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + conjg (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end do ierr = 0 end if end subroutine clmbv_coo ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_coo (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,i,ofs character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + conjg (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + conjg (mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end do ierr = 0 end if end subroutine zlmbv_coo ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_coo SHAR_EOF fi # end of overwriting check if test -f 'lmbv_csc.f90' then echo shar: will not over-write existing file "'lmbv_csc.f90'" else cat << "SHAR_EOF" > 'lmbv_csc.f90' module mod_lmbv_csc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'CSC'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties implicit none interface lmbv_csc module procedure ilmbv_csc module procedure slmbv_csc module procedure dlmbv_csc module procedure clmbv_csc module procedure zlmbv_csc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_csc (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine ilmbv_csc ! ********************************************************************** ! ********************************************************************** subroutine slmbv_csc (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine slmbv_csc ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_csc (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine dlmbv_csc ! ********************************************************************** ! ********************************************************************** subroutine clmbv_csc (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + conjg (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + conjg (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine clmbv_csc ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_csc (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + conjg (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + conjg (mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zlmbv_csc ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_csc SHAR_EOF fi # end of overwriting check if test -f 'lmbv_csr.f90' then echo shar: will not over-write existing file "'lmbv_csr.f90'" else cat << "SHAR_EOF" > 'lmbv_csr.f90' module mod_lmbv_csr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'CSR'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties implicit none interface lmbv_csr module procedure ilmbv_csr module procedure slmbv_csr module procedure dlmbv_csr module procedure clmbv_csr module procedure zlmbv_csr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_csr (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + (mat%A(pntr + ofs)) & * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + (mat%A(pntr + ofs))& * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine ilmbv_csr ! ********************************************************************** ! ********************************************************************** subroutine slmbv_csr (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + (mat%A(pntr + ofs)) & * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + (mat%A(pntr + ofs))& * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine slmbv_csr ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_csr (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + (mat%A(pntr + ofs)) & * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + (mat%A(pntr + ofs))& * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine dlmbv_csr ! ********************************************************************** ! ********************************************************************** subroutine clmbv_csr (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + conjg (mat%A(pntr + ofs)) & * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + conjg (mat%A(pntr + ofs))& * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine clmbv_csr ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_csr (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + conjg (mat%A(pntr + ofs)) & * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + conjg (mat%A(pntr + ofs))& * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zlmbv_csr ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_csr SHAR_EOF fi # end of overwriting check if test -f 'lmbv_dia.f90' then echo shar: will not over-write existing file "'lmbv_dia.f90'" else cat << "SHAR_EOF" > 'lmbv_dia.f90' module mod_lmbv_dia ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'DIA'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties implicit none interface lmbv_dia module procedure ilmbv_dia module procedure slmbv_dia module procedure dlmbv_dia module procedure clmbv_dia module procedure zlmbv_dia end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_dia (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + mat%A(start_a+j) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine ilmbv_dia ! ********************************************************************** ! ********************************************************************** subroutine slmbv_dia (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + mat%A(start_a+j) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine slmbv_dia ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_dia (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + mat%A(start_a+j) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine dlmbv_dia ! ********************************************************************** ! ********************************************************************** subroutine clmbv_dia (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + mat%A(start_a+j) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + conjg (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + conjg (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine clmbv_dia ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_dia (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + mat%A(start_a+j) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + conjg (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + conjg (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine zlmbv_dia ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_dia SHAR_EOF fi # end of overwriting check if test -f 'lmbv_vbr.f90' then echo shar: will not over-write existing file "'lmbv_vbr.f90'" else cat << "SHAR_EOF" > 'lmbv_vbr.f90' module mod_lmbv_vbr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'VBR'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_vbr module procedure ilmbv_vbr module procedure slmbv_vbr module procedure dlmbv_vbr module procedure clmbv_vbr module procedure zlmbv_vbr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilmbv_vbr (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine ilmbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine slmbv_vbr (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine slmbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine dlmbv_vbr (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine dlmbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine clmbv_vbr (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine clmbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine zlmbv_vbr (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zlmbv_vbr ! ********************************************************************** ! ********************************************************************** end module mod_lmbv_vbr SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bco.f90' then echo shar: will not over-write existing file "'lsbv_bco.f90'" else cat << "SHAR_EOF" > 'lsbv_bco.f90' module mod_lsbv_bco ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BCO'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use mod_hash use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_bco module procedure ilsbv_bco module procedure slsbv_bco module procedure dlsbv_bco module procedure clsbv_bco module procedure zlsbv_bco end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_bco (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb,nnz integer :: mm,nn,nn_sq character :: diag,part,store type(capsule), pointer :: dummy integer , allocatable, dimension(:) :: y !extra stor.! ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,& (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = 1,nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine ilsbv_bco ! ********************************************************************** ! ********************************************************************** subroutine slsbv_bco (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb,nnz integer :: mm,nn,nn_sq character :: diag,part,store type(capsule), pointer :: dummy real(KIND=sp) , allocatable, dimension(:) :: y !extra stor.! ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,& (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = 1,nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine slsbv_bco ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_bco (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb,nnz integer :: mm,nn,nn_sq character :: diag,part,store type(capsule), pointer :: dummy real(KIND=dp) , allocatable, dimension(:) :: y !extra stor.! ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,& (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = 1,nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine dlsbv_bco ! ********************************************************************** ! ********************************************************************** subroutine clsbv_bco (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb,nnz integer :: mm,nn,nn_sq character :: diag,part,store type(capsule), pointer :: dummy complex(KIND=sp) , allocatable, dimension(:) :: y !extra stor.! ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,& (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = 1,nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine clsbv_bco ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_bco (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb,nnz integer :: mm,nn,nn_sq character :: diag,part,store type(capsule), pointer :: dummy complex(KIND=dp) , allocatable, dimension(:) :: y !extra stor.! ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,& (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = 1,nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine zlsbv_bco ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_bco SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bdi.f90' then echo shar: will not over-write existing file "'lsbv_bdi.f90'" else cat << "SHAR_EOF" > 'lsbv_bdi.f90' module mod_lsbv_bdi ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BDI'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_bdi module procedure ilsbv_bdi module procedure slsbv_bdi module procedure dlsbv_bdi module procedure clsbv_bdi module procedure zlsbv_bdi end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_bdi (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 if (part.eq.'L') then do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine ilsbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine slsbv_bdi (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 if (part.eq.'L') then do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine slsbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_bdi (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 if (part.eq.'L') then do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine dlsbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine clsbv_bdi (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) if (part.eq.'L') then do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine clsbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_bdi (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) if (part.eq.'L') then do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine zlsbv_bdi ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_bdi SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bsc.f90' then echo shar: will not over-write existing file "'lsbv_bsc.f90'" else cat << "SHAR_EOF" > 'lsbv_bsc.f90' module mod_lsbv_bsc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BSC'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_bsc module procedure ilsbv_bsc module procedure slsbv_bsc module procedure dlsbv_bsc module procedure clsbv_bsc module procedure zlsbv_bsc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_bsc (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 if (part.eq.'L') then do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine ilsbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine slsbv_bsc (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 if (part.eq.'L') then do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine slsbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_bsc (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 if (part.eq.'L') then do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine dlsbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine clsbv_bsc (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) if (part.eq.'L') then do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine clsbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_bsc (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) if (part.eq.'L') then do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine zlsbv_bsc ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_bsc SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bsr.f90' then echo shar: will not over-write existing file "'lsbv_bsr.f90'" else cat << "SHAR_EOF" > 'lsbv_bsr.f90' module mod_lsbv_bsr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH TRANSPOSE IN 'BSR'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_bsr module procedure ilsbv_bsr module procedure slsbv_bsr module procedure dlsbv_bsr module procedure clsbv_bsr module procedure zlsbv_bsr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_bsr (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine ilsbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine slsbv_bsr (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine slsbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_bsr (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine dlsbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine clsbv_bsr (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine clsbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_bsr (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine zlsbv_bsr ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_bsr SHAR_EOF fi # end of overwriting check if test -f 'lsbv_coo.f90' then echo shar: will not over-write existing file "'lsbv_coo.f90'" else cat << "SHAR_EOF" > 'lsbv_coo.f90' module mod_lsbv_coo ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'COO'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use mod_hash use representation_of_data use properties implicit none interface lsbv_coo module procedure ilsbv_coo module procedure slsbv_coo module procedure dlsbv_coo module procedure clsbv_coo module procedure zlsbv_coo end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_coo (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine ilsbv_coo ! ********************************************************************** ! ********************************************************************** subroutine slsbv_coo (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0.0e0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0.0e0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine slsbv_coo ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_coo (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0.0d0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0.0d0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine dlsbv_coo ! ********************************************************************** ! ********************************************************************** subroutine clsbv_coo (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. (0.0e0, 0.0e0) ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. (0.0e0, 0.0e0) ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine clsbv_coo ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_coo (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. (0.0d0, 0.0d0) ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. (0.0d0, 0.0d0) ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine zlsbv_coo ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_coo SHAR_EOF fi # end of overwriting check if test -f 'lsbv_csc.f90' then echo shar: will not over-write existing file "'lsbv_csc.f90'" else cat << "SHAR_EOF" > 'lsbv_csc.f90' module mod_lsbv_csc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH TRANSPOSE IN 'CSC'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface lsbv_csc module procedure ilsbv_csc module procedure slsbv_csc module procedure dlsbv_csc module procedure clsbv_csc module procedure zlsbv_csc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_csc (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part integer :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = 0 pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. 0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = 0 pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. 0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine ilsbv_csc ! ********************************************************************** ! ********************************************************************** subroutine slsbv_csc (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part real(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = 0.0e0 pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. 0.0e0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = 0.0e0 pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. 0.0e0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine slsbv_csc ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_csc (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part real(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = 0.0d0 pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. 0.0d0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = 0.0d0 pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. 0.0d0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine dlsbv_csc ! ********************************************************************** ! ********************************************************************** subroutine clsbv_csc (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part complex(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = (0.0e0, 0.0e0) pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. (0.0e0, 0.0e0) ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = (0.0e0, 0.0e0) pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. (0.0e0, 0.0e0) ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine clsbv_csc ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_csc (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part complex(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = (0.0d0, 0.0d0) pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. (0.0d0, 0.0d0) ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = (0.0d0, 0.0d0) pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq. (0.0d0, 0.0d0) ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine zlsbv_csc ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_csc SHAR_EOF fi # end of overwriting check if test -f 'lsbv_csr.f90' then echo shar: will not over-write existing file "'lsbv_csr.f90'" else cat << "SHAR_EOF" > 'lsbv_csr.f90' module mod_lsbv_csr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH TRANSPOSE IN 'CSR'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface lsbv_csr module procedure ilsbv_csr module procedure slsbv_csr module procedure dlsbv_csr module procedure clsbv_csr module procedure zlsbv_csr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_csr (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part integer :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine ilsbv_csr ! ********************************************************************** ! ********************************************************************** subroutine slsbv_csr (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part real(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0.0e0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0.0e0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine slsbv_csr ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_csr (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part real(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0.0d0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0.0d0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine dlsbv_csr ! ********************************************************************** ! ********************************************************************** subroutine clsbv_csr (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part complex(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. (0.0e0, 0.0e0) ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. (0.0e0, 0.0e0) ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine clsbv_csr ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_csr (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part complex(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. (0.0d0, 0.0d0) ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. (0.0d0, 0.0d0) ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine zlsbv_csr ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_csr SHAR_EOF fi # end of overwriting check if test -f 'lsbv_dia.f90' then echo shar: will not over-write existing file "'lsbv_dia.f90'" else cat << "SHAR_EOF" > 'lsbv_dia.f90' module mod_lsbv_dia ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'DIA'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface lsbv_dia module procedure ilsbv_dia module procedure slsbv_dia module procedure dlsbv_dia module procedure clsbv_dia module procedure zlsbv_dia end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_dia (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part integer :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do else de = 0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do if (de.ne. 0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do else de = 0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do if (de.ne. 0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine ilsbv_dia ! ********************************************************************** ! ********************************************************************** subroutine slsbv_dia (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part real(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do else de = 0.0e0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do if (de.ne. 0.0e0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do else de = 0.0e0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do if (de.ne. 0.0e0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine slsbv_dia ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_dia (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part real(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do else de = 0.0d0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do if (de.ne. 0.0d0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do else de = 0.0d0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do if (de.ne. 0.0d0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine dlsbv_dia ! ********************************************************************** ! ********************************************************************** subroutine clsbv_dia (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part complex(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do else de = (0.0e0, 0.0e0) do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do if (de.ne. (0.0e0, 0.0e0) ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do else de = (0.0e0, 0.0e0) do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do if (de.ne. (0.0e0, 0.0e0) ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine clsbv_dia ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_dia (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part complex(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do else de = (0.0d0, 0.0d0) do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do if (de.ne. (0.0d0, 0.0d0) ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do else de = (0.0d0, 0.0d0) do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do if (de.ne. (0.0d0, 0.0d0) ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine zlsbv_dia ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_dia SHAR_EOF fi # end of overwriting check if test -f 'lsbv_vbr.f90' then echo shar: will not over-write existing file "'lsbv_vbr.f90'" else cat << "SHAR_EOF" > 'lsbv_vbr.f90' module mod_lsbv_vbr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'VBR'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_vbr module procedure ilsbv_vbr module procedure slsbv_vbr module procedure dlsbv_vbr module procedure clsbv_vbr module procedure zlsbv_vbr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine ilsbv_vbr (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_left_lower(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_right_upper(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine ilsbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine slsbv_vbr (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_left_lower(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_right_upper(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine slsbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine dlsbv_vbr (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_left_lower(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_right_upper(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine dlsbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine clsbv_vbr (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_left_lower(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_right_upper(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine clsbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine zlsbv_vbr (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_left_lower(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_right_upper(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine zlsbv_vbr ! ********************************************************************** ! ********************************************************************** end module mod_lsbv_vbr SHAR_EOF fi # end of overwriting check if test -f 'mbv.f90' then echo shar: will not over-write existing file "'mbv.f90'" else cat << "SHAR_EOF" > 'mbv.f90' module mod_mbv ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 29.2.00 ! ! Description : JUST A CONTAINER FOR ALL mod_Xmbv_XXX ! ********************************************************************** use mod_lmbv_coo use mod_rmbv_coo use mod_lmbv_csc use mod_rmbv_csc use mod_lmbv_csr use mod_rmbv_csr use mod_lmbv_dia use mod_rmbv_dia use mod_lmbv_bco use mod_rmbv_bco use mod_lmbv_bsr use mod_rmbv_bsr use mod_lmbv_bsc use mod_rmbv_bsc use mod_lmbv_bdi use mod_rmbv_bdi use mod_lmbv_vbr use mod_rmbv_vbr end module mod_mbv SHAR_EOF fi # end of overwriting check if test -f 'properties.f90' then echo shar: will not over-write existing file "'properties.f90'" else cat << "SHAR_EOF" > 'properties.f90' module properties ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 3.1.2002 ! ! Description : CONTAINS ALL CONSTANTS USED FROM THE LIBRARY ! CONTAINS ROUTINES FOR MANIPULATING THE ARRAYS ! INFOA & DESCRA OF THE DERIVED DATATYPE ! FOR SPARSE MATRICES ! get_descra:returns matrix properties stored as chars ! set_descra:translates integer in character descript. ! of sparse matrix, used by uscr ! get_infoa:returns matrix properties stored as ints ! set_infoa:sets matrix properties stored as ints ! ! ********************************************************************** use blas_sparse_namedconstants implicit none ! *** Description of basic derived data types integer, parameter :: no_of_types = 5 integer, parameter :: ISP_MATRIX = 0 integer, parameter :: DSP_MATRIX = 1 integer, parameter :: SSP_MATRIX = 2 integer, parameter :: CSP_MATRIX = 3 integer, parameter :: ZSP_MATRIX = 4 ! *** Determine, if array indices start at 0 or 1 integer, parameter :: C_BASE = 0 integer, parameter :: F_BASE = 1 ! *** Determine, if matrix is reference or copy of original data integer, parameter :: REF_OF_SOURCE = 0 integer, parameter :: COP_OF_SOURCE = 1 ! *** Determine, if the matrix is needed or its (conjugate) transpose integer, parameter :: ORIGIN_MATRIX = 0 integer, parameter :: TRANSP_MATRIX = 1 integer, parameter :: HERMIT_MATRIX = 2 contains subroutine get_descra(descra,descriptor,message,ierr) implicit none character*11, intent(in) :: descra character, intent(in) :: descriptor character, intent(out) :: message integer, intent(out) :: ierr ierr = -1 message = '' select case(descriptor) case('a') !lower,upper or both parts message = descra(3:3) case('b') !base message = descra(5:5) case('d') !unity diagonal stored or not message = descra(1:1) case('f') !internal block storage is row- or column-wise message = descra(7:7) case('r') !repeated indices message = descra(2:2) case('s') !structure of matrix message = descra(4:4) case('t') !matrix type message = descra(6:6) case default return end select ierr = 0 end subroutine get_descra subroutine set_descra(descra,prpty,ierr) character*11, intent(out) :: descra integer, intent(in) :: prpty integer, intent(out) :: ierr integer :: dummy descra = '' ierr = -1 dummy = prpty !check, if matrix has unstored unity diagonal if (mod(dummy,2).eq.1) then descra(1:1) = 'U' else descra(1:1) = 'N' !DEFAULT end if dummy = dummy - mod(dummy,2) !repeated indices if (mod(dummy,4).eq.2) then descra(2:2) = 'R' else descra(2:2) = 'U' !DEFAULT end if dummy = dummy - mod(dummy,4) !both/lower/upper half of matrix specified select case(mod(dummy,16)) case(0) descra(3:3) = 'B' !DEFAULT case(4) descra(3:3) = 'U' case(8) descra(3:3) = 'L' case default return end select dummy = dummy - mod(dummy,16) !matrix is irregular/regular/unassembled select case(mod(dummy,64)) case(0) descra(4:4) = 'I' !DEFAULT case(16) descra(4:4) = 'R' case(32) descra(4:4) = 'U' case default return end select dummy = dummy - mod(dummy,64) !index base if (mod(dummy,128).eq.64) then descra(5:5) = 'C' else descra(5:5) = 'F' !DEFAULT end if dummy = dummy - mod(dummy,128) ! matrix type select case(mod(dummy,1024)) case (0) descra(6:6) = 'G' !DEFAULT case(128) descra(6:6) = 'S' case(256) descra(6:6) = 'H' case(512) descra(6:6) = 'T' case default return end select dummy = dummy - mod(dummy,1024) !internal block storage if (mod(dummy,2048).eq.1024) then descra(7:7) = 'R' else descra(7:7) = 'C' !DEFAULT end if dummy = dummy - mod(dummy,2048) ierr = 0 end subroutine set_descra subroutine get_infoa(infoa,descr,val,ierr) implicit none integer, dimension(10), intent(in) :: infoa character, intent(in) :: descr integer, intent(out) :: val,ierr val = -1 ierr = -1 select case(descr) case('b') !base of array indices val = infoa(2) case('c') !copy or not val = infoa(9) case('d') !multidim array:row-dim of block val = infoa(3) case('e') !multidim array:col-dim of block val = infoa(4) case('f') !Block structure array:row-dim in blocks val = infoa(5) case('g') !Block structure array:col-dim in blocks val = infoa(6) case('n') !nnz val = infoa(1) case default return end select ierr = 0 end subroutine get_infoa subroutine set_infoa(infoa,descr,val,ierr) implicit none integer, dimension(10), intent(inout) :: infoa character*1, intent(in) :: descr integer, intent(in) :: val integer, intent(out) :: ierr ierr = -1 if (val.lt.0) return select case(descr) case('b') !base of array indices infoa(2) = val case('c') !copy or not infoa(9) = val case('d') !multidim array:row-dim of blocks infoa(3) = val case('e') !multidim array:col-dim of blocks infoa(4) = val case('f') !Block structure array:row-dim in blocks infoa(5) = val case('g') !Block structure array:col-dim in blocks infoa(6) = val case('n') !nnz infoa(1) = val case default return end select ierr = 0 end subroutine set_infoa end module properties SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bco.f90' then echo shar: will not over-write existing file "'rmbv_bco.f90'" else cat << "SHAR_EOF" > 'rmbv_bco.f90' module mod_rmbv_bco ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BCO'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_bco module procedure irmbv_bco module procedure srmbv_bco module procedure drmbv_bco module procedure crmbv_bco module procedure zrmbv_bco end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_bco (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine irmbv_bco ! ********************************************************************** ! ********************************************************************** subroutine srmbv_bco (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0e0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine srmbv_bco ! ********************************************************************** ! ********************************************************************** subroutine drmbv_bco (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0d0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine drmbv_bco ! ********************************************************************** ! ********************************************************************** subroutine crmbv_bco (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine crmbv_bco ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_bco (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine zrmbv_bco ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_bco SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bdi.f90' then echo shar: will not over-write existing file "'rmbv_bdi.f90'" else cat << "SHAR_EOF" > 'rmbv_bdi.f90' module mod_rmbv_bdi ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BDI'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_bdi module procedure irmbv_bdi module procedure srmbv_bdi module procedure drmbv_bdi module procedure crmbv_bdi module procedure zrmbv_bdi end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_bdi (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine irmbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine srmbv_bdi (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0e0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine srmbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine drmbv_bdi (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0d0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine drmbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine crmbv_bdi (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine crmbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_bdi (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine zrmbv_bdi ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_bdi SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bsc.f90' then echo shar: will not over-write existing file "'rmbv_bsc.f90'" else cat << "SHAR_EOF" > 'rmbv_bsc.f90' module mod_rmbv_bsc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BSC'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_bsc module procedure irmbv_bsc module procedure srmbv_bsc module procedure drmbv_bsc module procedure crmbv_bsc module procedure zrmbv_bsc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_bsc (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine irmbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine srmbv_bsc (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0e0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine srmbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine drmbv_bsc (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0d0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine drmbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine crmbv_bsc (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine crmbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_bsc (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zrmbv_bsc ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_bsc SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bsr.f90' then echo shar: will not over-write existing file "'rmbv_bsr.f90'" else cat << "SHAR_EOF" > 'rmbv_bsr.f90' module mod_rmbv_bsr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BSR'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_bsr module procedure irmbv_bsr module procedure srmbv_bsr module procedure drmbv_bsr module procedure crmbv_bsr module procedure zrmbv_bsr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_bsr (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine irmbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine srmbv_bsr (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0e0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine srmbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine drmbv_bsr (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = 0.0d0 nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine drmbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine crmbv_bsr (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine crmbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_bsr (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zrmbv_bsr ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_bsr SHAR_EOF fi # end of overwriting check if test -f 'rmbv_coo.f90' then echo shar: will not over-write existing file "'rmbv_coo.f90'" else cat << "SHAR_EOF" > 'rmbv_coo.f90' module mod_rmbv_coo ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'COO'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties implicit none interface rmbv_coo module procedure irmbv_coo module procedure srmbv_coo module procedure drmbv_coo module procedure crmbv_coo module procedure zrmbv_coo end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_coo (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,ofs,i character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else do i = 1, nnz y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) end do ierr = 0 end if end subroutine irmbv_coo ! ********************************************************************** ! ********************************************************************** subroutine srmbv_coo (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,ofs,i character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else do i = 1, nnz y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) end do ierr = 0 end if end subroutine srmbv_coo ! ********************************************************************** ! ********************************************************************** subroutine drmbv_coo (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,ofs,i character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else do i = 1, nnz y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) end do ierr = 0 end if end subroutine drmbv_coo ! ********************************************************************** ! ********************************************************************** subroutine crmbv_coo (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,ofs,i character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + conjg (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + conjg (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else do i = 1, nnz y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) end do ierr = 0 end if end subroutine crmbv_coo ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_coo (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,ofs,i character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + conjg (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + conjg (mat%A(i)) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else do i = 1, nnz y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) end do ierr = 0 end if end subroutine zrmbv_coo ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_coo SHAR_EOF fi # end of overwriting check if test -f 'rmbv_csc.f90' then echo shar: will not over-write existing file "'rmbv_csc.f90'" else cat << "SHAR_EOF" > 'rmbv_csc.f90' module mod_rmbv_csc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'CSC'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties implicit none interface rmbv_csc module procedure irmbv_csc module procedure srmbv_csc module procedure drmbv_csc module procedure crmbv_csc module procedure zrmbv_csc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_csc (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + (mat%A(pntr + ofs)) * x(mat%IA1(pntr + ofs)+ ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs)+ofs) =y(mat%IA1(pntr+ofs)+ofs) & +mat%A(pntr + ofs) * x(j) y(j) = y(j) + (mat%A(pntr+ofs)) & * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine irmbv_csc ! ********************************************************************** ! ********************************************************************** subroutine srmbv_csc (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + (mat%A(pntr + ofs)) * x(mat%IA1(pntr + ofs)+ ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs)+ofs) =y(mat%IA1(pntr+ofs)+ofs) & +mat%A(pntr + ofs) * x(j) y(j) = y(j) + (mat%A(pntr+ofs)) & * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine srmbv_csc ! ********************************************************************** ! ********************************************************************** subroutine drmbv_csc (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + (mat%A(pntr + ofs)) * x(mat%IA1(pntr + ofs)+ ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs)+ofs) =y(mat%IA1(pntr+ofs)+ofs) & +mat%A(pntr + ofs) * x(j) y(j) = y(j) + (mat%A(pntr+ofs)) & * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine drmbv_csc ! ********************************************************************** ! ********************************************************************** subroutine crmbv_csc (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + conjg (mat%A(pntr + ofs)) * x(mat%IA1(pntr + ofs)+ ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs)+ofs) =y(mat%IA1(pntr+ofs)+ofs) & +mat%A(pntr + ofs) * x(j) y(j) = y(j) + conjg (mat%A(pntr+ofs)) & * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine crmbv_csc ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_csc (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + conjg (mat%A(pntr + ofs)) * x(mat%IA1(pntr + ofs)+ ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs)+ofs) =y(mat%IA1(pntr+ofs)+ofs) & +mat%A(pntr + ofs) * x(j) y(j) = y(j) + conjg (mat%A(pntr+ofs)) & * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zrmbv_csc ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_csc SHAR_EOF fi # end of overwriting check if test -f 'rmbv_csr.f90' then echo shar: will not over-write existing file "'rmbv_csr.f90'" else cat << "SHAR_EOF" > 'rmbv_csr.f90' module mod_rmbv_csr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'CSR'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties implicit none interface rmbv_csr module procedure irmbv_csr module procedure srmbv_csr module procedure drmbv_csr module procedure crmbv_csr module procedure zrmbv_csr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_csr (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine irmbv_csr ! ********************************************************************** ! ********************************************************************** subroutine srmbv_csr (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine srmbv_csr ! ********************************************************************** ! ********************************************************************** subroutine drmbv_csr (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine drmbv_csr ! ********************************************************************** ! ********************************************************************** subroutine crmbv_csr (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + conjg (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + conjg (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine crmbv_csr ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_csr (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + conjg (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + conjg (mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zrmbv_csr ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_csr SHAR_EOF fi # end of overwriting check if test -f 'rmbv_dia.f90' then echo shar: will not over-write existing file "'rmbv_dia.f90'" else cat << "SHAR_EOF" > 'rmbv_dia.f90' module mod_rmbv_dia ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'DIA'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties implicit none interface rmbv_dia module procedure irmbv_dia module procedure srmbv_dia module procedure drmbv_dia module procedure crmbv_dia module procedure zrmbv_dia end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_dia (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine irmbv_dia ! ********************************************************************** ! ********************************************************************** subroutine srmbv_dia (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine srmbv_dia ! ********************************************************************** ! ********************************************************************** subroutine drmbv_dia (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine drmbv_dia ! ********************************************************************** ! ********************************************************************** subroutine crmbv_dia (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + conjg (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + conjg (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine crmbv_dia ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_dia (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + conjg (mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + conjg (mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine zrmbv_dia ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_dia SHAR_EOF fi # end of overwriting check if test -f 'rmbv_vbr.f90' then echo shar: will not over-write existing file "'rmbv_vbr.f90'" else cat << "SHAR_EOF" > 'rmbv_vbr.f90' module mod_rmbv_vbr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS MV MULT. WITH MATRIX IN 'VBR'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_vbr module procedure irmbv_vbr module procedure srmbv_vbr module procedure drmbv_vbr module procedure crmbv_vbr module procedure zrmbv_vbr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irmbv_vbr (mat,x,y,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(in) :: x integer , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine irmbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine srmbv_vbr (mat,x,y,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0e0 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine srmbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine drmbv_vbr (mat,x,y,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = 0.0d0 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine drmbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine crmbv_vbr (mat,x,y,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0e0, 0.0e0) start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine crmbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine zrmbv_vbr (mat,x,y,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = (0.0d0, 0.0d0) start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine zrmbv_vbr ! ********************************************************************** ! ********************************************************************** end module mod_rmbv_vbr SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bco.f90' then echo shar: will not over-write existing file "'rsbv_bco.f90'" else cat << "SHAR_EOF" > 'rsbv_bco.f90' module mod_rsbv_bco ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BCO'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use mod_hash use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_bco module procedure irsbv_bco module procedure srsbv_bco module procedure drsbv_bco module procedure crsbv_bco module procedure zrsbv_bco end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_bco (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb integer :: mm,nn,nnz,nn_sq character :: diag,part,store type(capsule), pointer :: dummy integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or. & (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs, & (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine irsbv_bco ! ********************************************************************** ! ********************************************************************** subroutine srsbv_bco (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb integer :: mm,nn,nnz,nn_sq character :: diag,part,store type(capsule), pointer :: dummy real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or. & (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs, & (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine srsbv_bco ! ********************************************************************** ! ********************************************************************** subroutine drsbv_bco (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb integer :: mm,nn,nnz,nn_sq character :: diag,part,store type(capsule), pointer :: dummy real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or. & (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs, & (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine drsbv_bco ! ********************************************************************** ! ********************************************************************** subroutine crsbv_bco (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb integer :: mm,nn,nnz,nn_sq character :: diag,part,store type(capsule), pointer :: dummy complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or. & (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs, & (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine crsbv_bco ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_bco (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb integer :: mm,nn,nnz,nn_sq character :: diag,part,store type(capsule), pointer :: dummy complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or. & (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs, & (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine zrsbv_bco ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_bco SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bdi.f90' then echo shar: will not over-write existing file "'rsbv_bdi.f90'" else cat << "SHAR_EOF" > 'rsbv_bdi.f90' module mod_rsbv_bdi ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BDI'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_bdi module procedure irsbv_bdi module procedure srsbv_bdi module procedure drsbv_bdi module procedure crsbv_bdi module procedure zrsbv_bdi end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_bdi (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 if (part.eq.'L') then do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0))& then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).gt.0))then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine irsbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine srsbv_bdi (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 if (part.eq.'L') then do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0))& then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).gt.0))then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine srsbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine drsbv_bdi (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 if (part.eq.'L') then do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0))& then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).gt.0))then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine drsbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine crsbv_bdi (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) if (part.eq.'L') then do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0))& then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).gt.0))then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine crsbv_bdi ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_bdi (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) if (part.eq.'L') then do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0))& then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).gt.0))then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine zrsbv_bdi ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_bdi SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bsc.f90' then echo shar: will not over-write existing file "'rsbv_bsc.f90'" else cat << "SHAR_EOF" > 'rsbv_bsc.f90' module mod_rsbv_bsc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BSC'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_bsc module procedure irsbv_bsc module procedure srsbv_bsc module procedure drsbv_bsc module procedure crsbv_bsc module procedure zrsbv_bsc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_bsc (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 if (part.eq.'L') then do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine irsbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine srsbv_bsc (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 if (part.eq.'L') then do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine srsbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine drsbv_bsc (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 if (part.eq.'L') then do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine drsbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine crsbv_bsc (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) if (part.eq.'L') then do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine crsbv_bsc ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_bsc (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) if (part.eq.'L') then do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine zrsbv_bsc ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_bsc SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bsr.f90' then echo shar: will not over-write existing file "'rsbv_bsr.f90'" else cat << "SHAR_EOF" > 'rsbv_bsr.f90' module mod_rsbv_bsr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BSR'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_bsr module procedure irsbv_bsr module procedure srsbv_bsr module procedure drsbv_bsr module procedure crsbv_bsr module procedure zrsbv_bsr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_bsr (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine irsbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine srsbv_bsr (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine srsbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine drsbv_bsr (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine drsbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine crsbv_bsr (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine crsbv_bsr ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_bsr (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine zrsbv_bsr ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_bsr SHAR_EOF fi # end of overwriting check if test -f 'rsbv_coo.f90' then echo shar: will not over-write existing file "'rsbv_coo.f90'" else cat << "SHAR_EOF" > 'rsbv_coo.f90' module mod_rsbv_coo ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'COO'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use mod_hash use representation_of_data use properties implicit none interface rsbv_coo module procedure irsbv_coo module procedure srsbv_coo module procedure drsbv_coo module procedure crsbv_coo module procedure zrsbv_coo end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_coo (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine irsbv_coo ! ********************************************************************** ! ********************************************************************** subroutine srsbv_coo (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0.0e0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0.0e0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine srsbv_coo ! ********************************************************************** ! ********************************************************************** subroutine drsbv_coo (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0.0d0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. 0.0d0 ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine drsbv_coo ! ********************************************************************** ! ********************************************************************** subroutine crsbv_coo (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. (0.0e0, 0.0e0) ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. (0.0e0, 0.0e0) ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine crsbv_coo ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_coo (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. (0.0d0, 0.0d0) ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne. (0.0d0, 0.0d0) ) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine zrsbv_coo ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_coo SHAR_EOF fi # end of overwriting check if test -f 'rsbv_csc.f90' then echo shar: will not over-write existing file "'rsbv_csc.f90'" else cat << "SHAR_EOF" > 'rsbv_csc.f90' module mod_rsbv_csc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'CSC'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface rsbv_csc module procedure irsbv_csc module procedure srsbv_csc module procedure drsbv_csc module procedure crsbv_csc module procedure zrsbv_csc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_csc (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part integer :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine irsbv_csc ! ********************************************************************** ! ********************************************************************** subroutine srsbv_csc (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part real(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0.0e0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0.0e0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine srsbv_csc ! ********************************************************************** ! ********************************************************************** subroutine drsbv_csc (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part real(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0.0d0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. 0.0d0 ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine drsbv_csc ! ********************************************************************** ! ********************************************************************** subroutine crsbv_csc (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part complex(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. (0.0e0, 0.0e0) ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. (0.0e0, 0.0e0) ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine crsbv_csc ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_csc (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part complex(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. (0.0d0, 0.0d0) ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq. (0.0d0, 0.0d0) ) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine zrsbv_csc ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_csc SHAR_EOF fi # end of overwriting check if test -f 'rsbv_csr.f90' then echo shar: will not over-write existing file "'rsbv_csr.f90'" else cat << "SHAR_EOF" > 'rsbv_csr.f90' module mod_rsbv_csr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'CSR'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface rsbv_csr module procedure irsbv_csr module procedure srsbv_csr module procedure drsbv_csr module procedure crsbv_csr module procedure zrsbv_csr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_csr (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part integer :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = 0 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. 0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = 0 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. 0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine irsbv_csr ! ********************************************************************** ! ********************************************************************** subroutine srsbv_csr (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part real(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = 0.0e0 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. 0.0e0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = 0.0e0 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. 0.0e0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine srsbv_csr ! ********************************************************************** ! ********************************************************************** subroutine drsbv_csr (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part real(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = 0.0d0 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. 0.0d0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = 0.0d0 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. 0.0d0 ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine drsbv_csr ! ********************************************************************** ! ********************************************************************** subroutine crsbv_csr (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part complex(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = (0.0e0, 0.0e0) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. (0.0e0, 0.0e0) ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = (0.0e0, 0.0e0) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. (0.0e0, 0.0e0) ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine crsbv_csr ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_csr (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part complex(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = (0.0d0, 0.0d0) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. (0.0d0, 0.0d0) ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = (0.0d0, 0.0d0) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq. (0.0d0, 0.0d0) ) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine zrsbv_csr ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_csr SHAR_EOF fi # end of overwriting check if test -f 'rsbv_dia.f90' then echo shar: will not over-write existing file "'rsbv_dia.f90'" else cat << "SHAR_EOF" > 'rsbv_dia.f90' module mod_rsbv_dia ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'DIA'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface rsbv_dia module procedure irsbv_dia module procedure srsbv_dia module procedure drsbv_dia module procedure crsbv_dia module procedure zrsbv_dia end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_dia (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part integer :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = 0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. 0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = 0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. 0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine irsbv_dia ! ********************************************************************** ! ********************************************************************** subroutine srsbv_dia (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part real(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = 0.0e0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. 0.0e0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = 0.0e0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. 0.0e0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine srsbv_dia ! ********************************************************************** ! ********************************************************************** subroutine drsbv_dia (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part real(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = 0.0d0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. 0.0d0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = 0.0d0 do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. 0.0d0 ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine drsbv_dia ! ********************************************************************** ! ********************************************************************** subroutine crsbv_dia (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part complex(KIND=sp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = (0.0e0, 0.0e0) do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. (0.0e0, 0.0e0) ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = (0.0e0, 0.0e0) do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. (0.0e0, 0.0e0) ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine crsbv_dia ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_dia (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part complex(KIND=dp) :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = (0.0d0, 0.0d0) do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. (0.0d0, 0.0d0) ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = (0.0d0, 0.0d0) do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne. (0.0d0, 0.0d0) ) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine zrsbv_dia ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_dia SHAR_EOF fi # end of overwriting check if test -f 'rsbv_vbr.f90' then echo shar: will not over-write existing file "'rsbv_vbr.f90'" else cat << "SHAR_EOF" > 'rsbv_vbr.f90' module mod_rsbv_vbr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'VBR'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_vbr module procedure irsbv_vbr module procedure srsbv_vbr module procedure drsbv_vbr module procedure crsbv_vbr module procedure zrsbv_vbr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine irsbv_vbr (mat,x,ierr) implicit none type(ispmat ), pointer :: mat integer , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store integer , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0 if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_left_lower(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_right_upper(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine irsbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine srsbv_vbr (mat,x,ierr) implicit none type(sspmat ), pointer :: mat real(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store real(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0e0 if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_left_lower(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_right_upper(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine srsbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine drsbv_vbr (mat,x,ierr) implicit none type(dspmat ), pointer :: mat real(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store real(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = 0.0d0 if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_left_lower(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_right_upper(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine drsbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine crsbv_vbr (mat,x,ierr) implicit none type(cspmat ), pointer :: mat complex(KIND=sp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store complex(KIND=sp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0e0, 0.0e0) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_left_lower(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_right_upper(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine crsbv_vbr ! ********************************************************************** ! ********************************************************************** subroutine zrsbv_vbr (mat,x,ierr) implicit none type(zspmat ), pointer :: mat complex(KIND=dp) , dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store complex(KIND=dp) , allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = (0.0d0, 0.0d0) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_left_lower(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_right_upper(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine zrsbv_vbr ! ********************************************************************** ! ********************************************************************** end module mod_rsbv_vbr SHAR_EOF fi # end of overwriting check if test -f 'sbv.f90' then echo shar: will not over-write existing file "'sbv.f90'" else cat << "SHAR_EOF" > 'sbv.f90' module mod_sbv ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 29.2.00 ! ! Description : JUST A CONTAINER FOR ALL mod_sbXv_XXX ! ********************************************************************** use mod_lsbv_coo use mod_rsbv_coo use mod_lsbv_csc use mod_rsbv_csc use mod_lsbv_csr use mod_rsbv_csr use mod_lsbv_dia use mod_rsbv_dia use mod_lsbv_bco use mod_rsbv_bco use mod_lsbv_bsr use mod_rsbv_bsr use mod_lsbv_bsc use mod_rsbv_bsc use mod_lsbv_bdi use mod_rsbv_bdi use mod_lsbv_vbr use mod_rsbv_vbr end module mod_sbv SHAR_EOF fi # end of overwriting check if test -f 'test.f90' then echo shar: will not over-write existing file "'test.f90'" else cat << "SHAR_EOF" > 'test.f90' program test ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : SAMPLE ROUTINE FOR THE CERFACS TECHNICAL REPORT ! ********************************************************************** ! include the SparseBLAS module use SparseBLAS ! matrix handle and other parameters integer :: a, istat, prpty ! dense vectors double precision, dimension(5) :: x,y ! matrix data in COO format double precision, parameter, dimension(14) :: A_val_coo = & (/ 11,51,31,32,34,52,13,23,33,14,24,42,55,44 /) integer, parameter, dimension(14) :: A_indx_coo = & (/ 1,5,3,3,3,5,1,2,3,1,2,4,5,4 /) integer, parameter, dimension(14) :: A_jndx_coo = & (/ 1,1,1,2,4,2,3,3,3,4,4,2,5,4 /) prpty = blas_general + blas_one_base istat = -1 ! copy data when creating handle ! create matrix handle call uscr_coo(5,5,A_val_coo,A_indx_coo,A_jndx_coo,14, & prpty,istat,a) if(istat.lt.0) then stop 'Error! No handle created!' end if ! calculate matrix-vector product y=A*x x = 1.0d0 call usmv(a,x,y,istat) if (istat.ne.0) then stop 'Error! Can''t perform MV multiplication!' end if ! release matrix handle call usds(a, istat) if (istat.ne.0) then stop 'Error! Handle not released!' end if end program SHAR_EOF fi # end of overwriting check if test -f 'types.f90' then echo shar: will not over-write existing file "'types.f90'" else cat << "SHAR_EOF" > 'types.f90' MODULE types use blas_sparse_namedconstants ! ********************************************************************** ! Author : Christof Voemel ! ! Date of last modification : 05.12.00 ! ! Description : CONTAINS THE BASIC TYPES FOR SPARSE MATRICES/VECTORS ! ********************************************************************** TYPE ISPMAT INTEGER :: M,K CHARACTER*5 :: FIDA CHARACTER*11 :: DESCRA INTEGER, DIMENSION(10) :: INFOA INTEGER, POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IA1,IA2,PB,PE,BP1,BP2 END TYPE ISPMAT TYPE DSPMAT INTEGER :: M,K CHARACTER*5 :: FIDA CHARACTER*11 :: DESCRA INTEGER, DIMENSION(10) :: INFOA REAL(KIND=dp), POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IA1,IA2,PB,PE,BP1,BP2 END TYPE DSPMAT TYPE SSPMAT INTEGER :: M,K CHARACTER*5 :: FIDA CHARACTER*11 :: DESCRA INTEGER, DIMENSION(10) :: INFOA REAL(KIND=sp), POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IA1,IA2,PB,PE,BP1,BP2 END TYPE SSPMAT TYPE CSPMAT INTEGER :: M,K CHARACTER*5 :: FIDA CHARACTER*11 :: DESCRA INTEGER, DIMENSION(10) :: INFOA COMPLEX(KIND=sp), POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IA1,IA2,PB,PE,BP1,BP2 END TYPE CSPMAT TYPE ZSPMAT INTEGER :: M,K CHARACTER*5 :: FIDA CHARACTER*11 :: DESCRA INTEGER, DIMENSION(10) :: INFOA COMPLEX(KIND=dp), POINTER, DIMENSION(:) :: A INTEGER, POINTER, DIMENSION(:) :: IA1,IA2,PB,PE,BP1,BP2 END TYPE ZSPMAT END MODULE types SHAR_EOF fi # end of overwriting check if test -f 'usaxpy.f90' then echo shar: will not over-write existing file "'usaxpy.f90'" else cat << "SHAR_EOF" > 'usaxpy.f90' module mod_usaxpy use blas_sparse_namedconstants interface usaxpy module procedure iusaxpy module procedure susaxpy module procedure dusaxpy module procedure cusaxpy module procedure zusaxpy end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iusaxpy (x,indx,y,alpha) integer ,dimension(:),intent(in) ::x integer ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in) ::indx integer ,intent(in) ,optional ::alpha integer :: i,t t=size(indx) if(t.gt.0) then if(present(alpha)) then do i=1,t y(indx(i))=y(indx(i))+x(i)*alpha end do else do i=1,t y(indx(i))=y(indx(i))+x(i) end do end if end if end subroutine iusaxpy ! ********************************************************************** ! ********************************************************************** subroutine susaxpy (x,indx,y,alpha) real(KIND=sp) ,dimension(:),intent(in) ::x real(KIND=sp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in) ::indx real(KIND=sp) ,intent(in) ,optional ::alpha integer :: i,t t=size(indx) if(t.gt.0) then if(present(alpha)) then do i=1,t y(indx(i))=y(indx(i))+x(i)*alpha end do else do i=1,t y(indx(i))=y(indx(i))+x(i) end do end if end if end subroutine susaxpy ! ********************************************************************** ! ********************************************************************** subroutine dusaxpy (x,indx,y,alpha) real(KIND=dp) ,dimension(:),intent(in) ::x real(KIND=dp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in) ::indx real(KIND=dp) ,intent(in) ,optional ::alpha integer :: i,t t=size(indx) if(t.gt.0) then if(present(alpha)) then do i=1,t y(indx(i))=y(indx(i))+x(i)*alpha end do else do i=1,t y(indx(i))=y(indx(i))+x(i) end do end if end if end subroutine dusaxpy ! ********************************************************************** ! ********************************************************************** subroutine cusaxpy (x,indx,y,alpha) complex(KIND=sp) ,dimension(:),intent(in) ::x complex(KIND=sp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in) ::indx complex(KIND=sp) ,intent(in) ,optional ::alpha integer :: i,t t=size(indx) if(t.gt.0) then if(present(alpha)) then do i=1,t y(indx(i))=y(indx(i))+x(i)*alpha end do else do i=1,t y(indx(i))=y(indx(i))+x(i) end do end if end if end subroutine cusaxpy ! ********************************************************************** ! ********************************************************************** subroutine zusaxpy (x,indx,y,alpha) complex(KIND=dp) ,dimension(:),intent(in) ::x complex(KIND=dp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in) ::indx complex(KIND=dp) ,intent(in) ,optional ::alpha integer :: i,t t=size(indx) if(t.gt.0) then if(present(alpha)) then do i=1,t y(indx(i))=y(indx(i))+x(i)*alpha end do else do i=1,t y(indx(i))=y(indx(i))+x(i) end do end if end if end subroutine zusaxpy ! ********************************************************************** ! ********************************************************************** end module mod_usaxpy SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bdi.f90' then echo shar: will not over-write existing file "'usconv_bco2bdi.f90'" else cat << "SHAR_EOF" > 'usconv_bco2bdi.f90' module mod_usconv_bco2bdi use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bco2bdi(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,BLDA,BNDIAG,mb,kb,lb,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data intrinsic min ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='BCO') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='BDI' call get_infoa(isp_data %INFOA ,'e',lb,ierr) call get_infoa(isp_data %INFOA ,'f',mb,ierr) call get_infoa(isp_data %INFOA ,'g',kb,ierr) BLDA=min(mb,kb) call ipre_usconv_bco2bdi (mb,kb,lb,isp_data %A,& isp_data %IA1,isp_data %IA2,BLDA,BNDIAG) nullify(isp_data %IA2) call set_infoa(isp_data %INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(isp_data %INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(isp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal call set_infoa(isp_data %INFOA,'g',BNDIAG,ierr) !no of diagonals end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='BCO') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='BDI' call get_infoa(ssp_data %INFOA ,'e',lb,ierr) call get_infoa(ssp_data %INFOA ,'f',mb,ierr) call get_infoa(ssp_data %INFOA ,'g',kb,ierr) BLDA=min(mb,kb) call spre_usconv_bco2bdi (mb,kb,lb,ssp_data %A,& ssp_data %IA1,ssp_data %IA2,BLDA,BNDIAG) nullify(ssp_data %IA2) call set_infoa(ssp_data %INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(ssp_data %INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(ssp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal call set_infoa(ssp_data %INFOA,'g',BNDIAG,ierr) !no of diagonals end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='BCO') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='BDI' call get_infoa(dsp_data %INFOA ,'e',lb,ierr) call get_infoa(dsp_data %INFOA ,'f',mb,ierr) call get_infoa(dsp_data %INFOA ,'g',kb,ierr) BLDA=min(mb,kb) call dpre_usconv_bco2bdi (mb,kb,lb,dsp_data %A,& dsp_data %IA1,dsp_data %IA2,BLDA,BNDIAG) nullify(dsp_data %IA2) call set_infoa(dsp_data %INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data %INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal call set_infoa(dsp_data %INFOA,'g',BNDIAG,ierr) !no of diagonals end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='BCO') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='BDI' call get_infoa(csp_data %INFOA ,'e',lb,ierr) call get_infoa(csp_data %INFOA ,'f',mb,ierr) call get_infoa(csp_data %INFOA ,'g',kb,ierr) BLDA=min(mb,kb) call cpre_usconv_bco2bdi (mb,kb,lb,csp_data %A,& csp_data %IA1,csp_data %IA2,BLDA,BNDIAG) nullify(csp_data %IA2) call set_infoa(csp_data %INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(csp_data %INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(csp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal call set_infoa(csp_data %INFOA,'g',BNDIAG,ierr) !no of diagonals end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='BCO') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='BDI' call get_infoa(zsp_data %INFOA ,'e',lb,ierr) call get_infoa(zsp_data %INFOA ,'f',mb,ierr) call get_infoa(zsp_data %INFOA ,'g',kb,ierr) BLDA=min(mb,kb) call zpre_usconv_bco2bdi (mb,kb,lb,zsp_data %A,& zsp_data %IA1,zsp_data %IA2,BLDA,BNDIAG) nullify(zsp_data %IA2) call set_infoa(zsp_data %INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(zsp_data %INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(zsp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal call set_infoa(zsp_data %INFOA,'g',BNDIAG,ierr) !no of diagonals end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bco2bdi end module mod_usconv_bco2bdi SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bsc.f90' then echo shar: will not over-write existing file "'usconv_bco2bsc.f90'" else cat << "SHAR_EOF" > 'usconv_bco2bsc.f90' module mod_usconv_bco2bsc use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bco2bsc(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,col_dim_in_blocks,col_dim_of_block,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='BCO') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='BSC' call get_infoa(isp_data %INFOA,'g',col_dim_in_blocks,ierr) call get_infoa(isp_data %INFOA,'e',col_dim_of_block,ierr) allocate(isp_data %PB(col_dim_in_blocks)) allocate(isp_data %PE(col_dim_in_blocks)) call ipre_usconv_bco2bsc (isp_data %A,isp_data %IA1,& isp_data %IA2,col_dim_in_blocks,& col_dim_of_block,isp_data %PB,isp_data %PE) nullify(isp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='BCO') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='BSC' call get_infoa(ssp_data %INFOA,'g',col_dim_in_blocks,ierr) call get_infoa(ssp_data %INFOA,'e',col_dim_of_block,ierr) allocate(ssp_data %PB(col_dim_in_blocks)) allocate(ssp_data %PE(col_dim_in_blocks)) call spre_usconv_bco2bsc (ssp_data %A,ssp_data %IA1,& ssp_data %IA2,col_dim_in_blocks,& col_dim_of_block,ssp_data %PB,ssp_data %PE) nullify(ssp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='BCO') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='BSC' call get_infoa(dsp_data %INFOA,'g',col_dim_in_blocks,ierr) call get_infoa(dsp_data %INFOA,'e',col_dim_of_block,ierr) allocate(dsp_data %PB(col_dim_in_blocks)) allocate(dsp_data %PE(col_dim_in_blocks)) call dpre_usconv_bco2bsc (dsp_data %A,dsp_data %IA1,& dsp_data %IA2,col_dim_in_blocks,& col_dim_of_block,dsp_data %PB,dsp_data %PE) nullify(dsp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='BCO') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='BSC' call get_infoa(csp_data %INFOA,'g',col_dim_in_blocks,ierr) call get_infoa(csp_data %INFOA,'e',col_dim_of_block,ierr) allocate(csp_data %PB(col_dim_in_blocks)) allocate(csp_data %PE(col_dim_in_blocks)) call cpre_usconv_bco2bsc (csp_data %A,csp_data %IA1,& csp_data %IA2,col_dim_in_blocks,& col_dim_of_block,csp_data %PB,csp_data %PE) nullify(csp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='BCO') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='BSC' call get_infoa(zsp_data %INFOA,'g',col_dim_in_blocks,ierr) call get_infoa(zsp_data %INFOA,'e',col_dim_of_block,ierr) allocate(zsp_data %PB(col_dim_in_blocks)) allocate(zsp_data %PE(col_dim_in_blocks)) call zpre_usconv_bco2bsc (zsp_data %A,zsp_data %IA1,& zsp_data %IA2,col_dim_in_blocks,& col_dim_of_block,zsp_data %PB,zsp_data %PE) nullify(zsp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bco2bsc end module mod_usconv_bco2bsc SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bsr.f90' then echo shar: will not over-write existing file "'usconv_bco2bsr.f90'" else cat << "SHAR_EOF" > 'usconv_bco2bsr.f90' module mod_usconv_bco2bsr use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bco2bsr(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,row_dim_in_blocks,col_dim_of_block,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='BCO') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='BSR' call get_infoa(isp_data %INFOA,'f',row_dim_in_blocks,ierr) call get_infoa(isp_data %INFOA,'e',col_dim_of_block,ierr) allocate(isp_data %PB(row_dim_in_blocks)) allocate(isp_data %PE(row_dim_in_blocks)) call ipre_usconv_bco2bsr (isp_data %A,isp_data %IA1,isp_data %IA2,& row_dim_in_blocks,col_dim_of_block,isp_data %PB,isp_data %PE) nullify(isp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='BCO') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='BSR' call get_infoa(ssp_data %INFOA,'f',row_dim_in_blocks,ierr) call get_infoa(ssp_data %INFOA,'e',col_dim_of_block,ierr) allocate(ssp_data %PB(row_dim_in_blocks)) allocate(ssp_data %PE(row_dim_in_blocks)) call spre_usconv_bco2bsr (ssp_data %A,ssp_data %IA1,ssp_data %IA2,& row_dim_in_blocks,col_dim_of_block,ssp_data %PB,ssp_data %PE) nullify(ssp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='BCO') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='BSR' call get_infoa(dsp_data %INFOA,'f',row_dim_in_blocks,ierr) call get_infoa(dsp_data %INFOA,'e',col_dim_of_block,ierr) allocate(dsp_data %PB(row_dim_in_blocks)) allocate(dsp_data %PE(row_dim_in_blocks)) call dpre_usconv_bco2bsr (dsp_data %A,dsp_data %IA1,dsp_data %IA2,& row_dim_in_blocks,col_dim_of_block,dsp_data %PB,dsp_data %PE) nullify(dsp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='BCO') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='BSR' call get_infoa(csp_data %INFOA,'f',row_dim_in_blocks,ierr) call get_infoa(csp_data %INFOA,'e',col_dim_of_block,ierr) allocate(csp_data %PB(row_dim_in_blocks)) allocate(csp_data %PE(row_dim_in_blocks)) call cpre_usconv_bco2bsr (csp_data %A,csp_data %IA1,csp_data %IA2,& row_dim_in_blocks,col_dim_of_block,csp_data %PB,csp_data %PE) nullify(csp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='BCO') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='BSR' call get_infoa(zsp_data %INFOA,'f',row_dim_in_blocks,ierr) call get_infoa(zsp_data %INFOA,'e',col_dim_of_block,ierr) allocate(zsp_data %PB(row_dim_in_blocks)) allocate(zsp_data %PE(row_dim_in_blocks)) call zpre_usconv_bco2bsr (zsp_data %A,zsp_data %IA1,zsp_data %IA2,& row_dim_in_blocks,col_dim_of_block,zsp_data %PB,zsp_data %PE) nullify(zsp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bco2bsr end module mod_usconv_bco2bsr SHAR_EOF fi # end of overwriting check if test -f 'usconv_bdi2bco.f90' then echo shar: will not over-write existing file "'usconv_bdi2bco.f90'" else cat << "SHAR_EOF" > 'usconv_bdi2bco.f90' module mod_usconv_bdi2bco use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bdi2bco(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,BLDA,BNNZ,mb,kb,lb,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data intrinsic floor ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='BDI') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='BCO' allocate(isp_data %IA2(2)) call get_infoa(isp_data %INFOA,'d',lb,ierr) !row-dim of a block call get_infoa(isp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal mb=floor(real(isp_data %M/lb)) kb=floor(real(isp_data %K/lb)) call set_infoa(isp_data %INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(isp_data %INFOA,'g',kb,ierr) !col-dim in blocks call ipre_usconv_bdi2bco (isp_data %A, isp_data %IA1,& isp_data %IA2,BLDA,BNNZ,lb) call set_infoa(isp_data %INFOA,'n',BNNZ,ierr) end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='BDI') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='BCO' allocate(ssp_data %IA2(2)) call get_infoa(ssp_data %INFOA,'d',lb,ierr) !row-dim of a block call get_infoa(ssp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal mb=floor(real(ssp_data %M/lb)) kb=floor(real(ssp_data %K/lb)) call set_infoa(ssp_data %INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(ssp_data %INFOA,'g',kb,ierr) !col-dim in blocks call spre_usconv_bdi2bco (ssp_data %A, ssp_data %IA1,& ssp_data %IA2,BLDA,BNNZ,lb) call set_infoa(ssp_data %INFOA,'n',BNNZ,ierr) end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='BDI') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='BCO' allocate(dsp_data %IA2(2)) call get_infoa(dsp_data %INFOA,'d',lb,ierr) !row-dim of a block call get_infoa(dsp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal mb=floor(real(dsp_data %M/lb)) kb=floor(real(dsp_data %K/lb)) call set_infoa(dsp_data %INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data %INFOA,'g',kb,ierr) !col-dim in blocks call dpre_usconv_bdi2bco (dsp_data %A, dsp_data %IA1,& dsp_data %IA2,BLDA,BNNZ,lb) call set_infoa(dsp_data %INFOA,'n',BNNZ,ierr) end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='BDI') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='BCO' allocate(csp_data %IA2(2)) call get_infoa(csp_data %INFOA,'d',lb,ierr) !row-dim of a block call get_infoa(csp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal mb=floor(real(csp_data %M/lb)) kb=floor(real(csp_data %K/lb)) call set_infoa(csp_data %INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(csp_data %INFOA,'g',kb,ierr) !col-dim in blocks call cpre_usconv_bdi2bco (csp_data %A, csp_data %IA1,& csp_data %IA2,BLDA,BNNZ,lb) call set_infoa(csp_data %INFOA,'n',BNNZ,ierr) end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='BDI') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='BCO' allocate(zsp_data %IA2(2)) call get_infoa(zsp_data %INFOA,'d',lb,ierr) !row-dim of a block call get_infoa(zsp_data %INFOA,'f',BLDA,ierr) !blocks per diagonal mb=floor(real(zsp_data %M/lb)) kb=floor(real(zsp_data %K/lb)) call set_infoa(zsp_data %INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(zsp_data %INFOA,'g',kb,ierr) !col-dim in blocks call zpre_usconv_bdi2bco (zsp_data %A, zsp_data %IA1,& zsp_data %IA2,BLDA,BNNZ,lb) call set_infoa(zsp_data %INFOA,'n',BNNZ,ierr) end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bdi2bco end module mod_usconv_bdi2bco SHAR_EOF fi # end of overwriting check if test -f 'usconv_bsc2bco.f90' then echo shar: will not over-write existing file "'usconv_bsc2bco.f90'" else cat << "SHAR_EOF" > 'usconv_bsc2bco.f90' module mod_usconv_bsc2bco use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bsc2bco(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,s,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='BSC') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='BCO' s=size(isp_data %IA1) allocate(isp_data %IA2(s)) call PNTR_INV( isp_data %PE, isp_data %IA2) nullify(isp_data %PB) nullify(isp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='BSC') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='BCO' s=size(ssp_data %IA1) allocate(ssp_data %IA2(s)) call PNTR_INV( ssp_data %PE, ssp_data %IA2) nullify(ssp_data %PB) nullify(ssp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='BSC') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='BCO' s=size(dsp_data %IA1) allocate(dsp_data %IA2(s)) call PNTR_INV( dsp_data %PE, dsp_data %IA2) nullify(dsp_data %PB) nullify(dsp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='BSC') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='BCO' s=size(csp_data %IA1) allocate(csp_data %IA2(s)) call PNTR_INV( csp_data %PE, csp_data %IA2) nullify(csp_data %PB) nullify(csp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='BSC') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='BCO' s=size(zsp_data %IA1) allocate(zsp_data %IA2(s)) call PNTR_INV( zsp_data %PE, zsp_data %IA2) nullify(zsp_data %PB) nullify(zsp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bsc2bco end module mod_usconv_bsc2bco SHAR_EOF fi # end of overwriting check if test -f 'usconv_bsr2bco.f90' then echo shar: will not over-write existing file "'usconv_bsr2bco.f90'" else cat << "SHAR_EOF" > 'usconv_bsr2bco.f90' module mod_usconv_bsr2bco use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bsr2bco(a,ierr) integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,s,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='BSR') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='BCO' s=size(isp_data %IA1) allocate(isp_data %IA2(s)) isp_data %IA2= isp_data %IA1 call PNTR_INV( isp_data %PE, isp_data %IA1) nullify(isp_data %PB) nullify(isp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='BSR') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='BCO' s=size(ssp_data %IA1) allocate(ssp_data %IA2(s)) ssp_data %IA2= ssp_data %IA1 call PNTR_INV( ssp_data %PE, ssp_data %IA1) nullify(ssp_data %PB) nullify(ssp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='BSR') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='BCO' s=size(dsp_data %IA1) allocate(dsp_data %IA2(s)) dsp_data %IA2= dsp_data %IA1 call PNTR_INV( dsp_data %PE, dsp_data %IA1) nullify(dsp_data %PB) nullify(dsp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='BSR') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='BCO' s=size(csp_data %IA1) allocate(csp_data %IA2(s)) csp_data %IA2= csp_data %IA1 call PNTR_INV( csp_data %PE, csp_data %IA1) nullify(csp_data %PB) nullify(csp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='BSR') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='BCO' s=size(zsp_data %IA1) allocate(zsp_data %IA2(s)) zsp_data %IA2= zsp_data %IA1 call PNTR_INV( zsp_data %PE, zsp_data %IA1) nullify(zsp_data %PB) nullify(zsp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bsr2bco end module mod_usconv_bsr2bco SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2csc.f90' then echo shar: will not over-write existing file "'usconv_coo2csc.f90'" else cat << "SHAR_EOF" > 'usconv_coo2csc.f90' module mod_usconv_coo2csc use properties use mod_conv_tools use representation_of_data contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine iusconv_coo2csc (a,ierr) integer,intent(inout) :: a type( ispmat ), pointer :: dspmtx integer ,intent(inout)::ierr integer :: res ierr=-1 call accessdata(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dspmtx%FIDA=='COO') then call get_infoa(dspmtx%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dspmtx%FIDA='CSC' allocate(dspmtx%PB(dspmtx%K)) allocate(dspmtx%PE(dspmtx%K)) call ipre_usconv_coo2csc ( dspmtx%A, dspmtx%IA1, dspmtx%IA2,& dspmtx%K, dspmtx%PB, dspmtx%PE) nullify(dspmtx%IA2) end if else ierr = blas_error_param return end if end subroutine iusconv_coo2csc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine susconv_coo2csc (a,ierr) integer,intent(inout) :: a type( sspmat ), pointer :: dspmtx integer ,intent(inout)::ierr integer :: res ierr=-1 call accessdata(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dspmtx%FIDA=='COO') then call get_infoa(dspmtx%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dspmtx%FIDA='CSC' allocate(dspmtx%PB(dspmtx%K)) allocate(dspmtx%PE(dspmtx%K)) call spre_usconv_coo2csc ( dspmtx%A, dspmtx%IA1, dspmtx%IA2,& dspmtx%K, dspmtx%PB, dspmtx%PE) nullify(dspmtx%IA2) end if else ierr = blas_error_param return end if end subroutine susconv_coo2csc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine dusconv_coo2csc (a,ierr) integer,intent(inout) :: a type( dspmat ), pointer :: dspmtx integer ,intent(inout)::ierr integer :: res ierr=-1 call accessdata(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dspmtx%FIDA=='COO') then call get_infoa(dspmtx%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dspmtx%FIDA='CSC' allocate(dspmtx%PB(dspmtx%K)) allocate(dspmtx%PE(dspmtx%K)) call dpre_usconv_coo2csc ( dspmtx%A, dspmtx%IA1, dspmtx%IA2,& dspmtx%K, dspmtx%PB, dspmtx%PE) nullify(dspmtx%IA2) end if else ierr = blas_error_param return end if end subroutine dusconv_coo2csc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine cusconv_coo2csc (a,ierr) integer,intent(inout) :: a type( cspmat ), pointer :: dspmtx integer ,intent(inout)::ierr integer :: res ierr=-1 call accessdata(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dspmtx%FIDA=='COO') then call get_infoa(dspmtx%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dspmtx%FIDA='CSC' allocate(dspmtx%PB(dspmtx%K)) allocate(dspmtx%PE(dspmtx%K)) call cpre_usconv_coo2csc ( dspmtx%A, dspmtx%IA1, dspmtx%IA2,& dspmtx%K, dspmtx%PB, dspmtx%PE) nullify(dspmtx%IA2) end if else ierr = blas_error_param return end if end subroutine cusconv_coo2csc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine zusconv_coo2csc (a,ierr) integer,intent(inout) :: a type( zspmat ), pointer :: dspmtx integer ,intent(inout)::ierr integer :: res ierr=-1 call accessdata(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dspmtx%FIDA=='COO') then call get_infoa(dspmtx%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dspmtx%FIDA='CSC' allocate(dspmtx%PB(dspmtx%K)) allocate(dspmtx%PE(dspmtx%K)) call zpre_usconv_coo2csc ( dspmtx%A, dspmtx%IA1, dspmtx%IA2,& dspmtx%K, dspmtx%PB, dspmtx%PE) nullify(dspmtx%IA2) end if else ierr = blas_error_param return end if end subroutine zusconv_coo2csc ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_usconv_coo2csc SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2csr.f90' then echo shar: will not over-write existing file "'usconv_coo2csr.f90'" else cat << "SHAR_EOF" > 'usconv_coo2csr.f90' module mod_usconv_coo2csr use properties use mod_conv_tools use representation_of_data contains subroutine usconv_coo2csr(a,ierr) implicit none integer,intent(inout) :: a type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer ,intent(inout)::ierr integer :: res,rest ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) !!*************************************************************************** ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='COO') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='CSR' allocate(isp_data %PB(isp_data %K)) allocate(isp_data %PE(isp_data %K)) call ipre_usconv_coo2csr ( isp_data %A, isp_data %IA1, & isp_data %IA2, isp_data %M, isp_data %PB, isp_data %PE) nullify(isp_data %IA2) end if else ierr = blas_error_param return end if case(SSP_MATRIX) !!*************************************************************************** ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='COO') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='CSR' allocate(ssp_data %PB(ssp_data %K)) allocate(ssp_data %PE(ssp_data %K)) call spre_usconv_coo2csr ( ssp_data %A, ssp_data %IA1, & ssp_data %IA2, ssp_data %M, ssp_data %PB, ssp_data %PE) nullify(ssp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** !!*************************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='COO') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='CSR' allocate(dsp_data %PB(dsp_data %K)) allocate(dsp_data %PE(dsp_data %K)) call dpre_usconv_coo2csr ( dsp_data %A, dsp_data %IA1, & dsp_data %IA2, dsp_data %M, dsp_data %PB, dsp_data %PE) nullify(dsp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** !!*************************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='COO') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='CSR' allocate(csp_data %PB(csp_data %K)) allocate(csp_data %PE(csp_data %K)) call cpre_usconv_coo2csr ( csp_data %A, csp_data %IA1, & csp_data %IA2, csp_data %M, csp_data %PB, csp_data %PE) nullify(csp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** !!*************************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='COO') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='CSR' allocate(zsp_data %PB(zsp_data %K)) allocate(zsp_data %PE(zsp_data %K)) call zpre_usconv_coo2csr ( zsp_data %A, zsp_data %IA1, & zsp_data %IA2, zsp_data %M, zsp_data %PB, zsp_data %PE) nullify(zsp_data %IA2) end if else ierr = blas_error_param return end if ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_coo2csr end module mod_usconv_coo2csr SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2dia.f90' then echo shar: will not over-write existing file "'usconv_coo2dia.f90'" else cat << "SHAR_EOF" > 'usconv_coo2dia.f90' module mod_usconv_coo2dia use properties use mod_conv_tools use representation_of_data contains subroutine usconv_coo2dia(a,ierr) implicit none integer,intent(inout) :: a type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer ,intent(inout)::ierr integer :: res,LDA,NDIAG,nnz,rest rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** ierr=-1 call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='COO') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='DIA' call ipre_usconv_coo2dia ( isp_data %M, isp_data %K, isp_data %A,& isp_data %IA1, isp_data %IA2,LDA,NDIAG) nullify(isp_data %IA2) nnz = count( isp_data %A.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored ! end if call set_infoa(isp_data %INFOA,'n',nnz,ierr) call set_infoa(isp_data %INFOA,'d',LDA,ierr) !row-dim of val call set_infoa(isp_data %INFOA,'e',NDIAG,ierr) !col-dim of val end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** ierr=-1 call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='COO') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='DIA' call spre_usconv_coo2dia ( ssp_data %M, ssp_data %K, ssp_data %A,& ssp_data %IA1, ssp_data %IA2,LDA,NDIAG) nullify(ssp_data %IA2) nnz = count( ssp_data %A.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored ! end if call set_infoa(ssp_data %INFOA,'n',nnz,ierr) call set_infoa(ssp_data %INFOA,'d',LDA,ierr) !row-dim of val call set_infoa(ssp_data %INFOA,'e',NDIAG,ierr) !col-dim of val end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** ierr=-1 call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='COO') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='DIA' call dpre_usconv_coo2dia ( dsp_data %M, dsp_data %K, dsp_data %A,& dsp_data %IA1, dsp_data %IA2,LDA,NDIAG) nullify(dsp_data %IA2) nnz = count( dsp_data %A.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored ! end if call set_infoa(dsp_data %INFOA,'n',nnz,ierr) call set_infoa(dsp_data %INFOA,'d',LDA,ierr) !row-dim of val call set_infoa(dsp_data %INFOA,'e',NDIAG,ierr) !col-dim of val end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** ierr=-1 call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='COO') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='DIA' call cpre_usconv_coo2dia ( csp_data %M, csp_data %K, csp_data %A,& csp_data %IA1, csp_data %IA2,LDA,NDIAG) nullify(csp_data %IA2) nnz = count( csp_data %A.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored ! end if call set_infoa(csp_data %INFOA,'n',nnz,ierr) call set_infoa(csp_data %INFOA,'d',LDA,ierr) !row-dim of val call set_infoa(csp_data %INFOA,'e',NDIAG,ierr) !col-dim of val end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** ierr=-1 call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='COO') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='DIA' call zpre_usconv_coo2dia ( zsp_data %M, zsp_data %K, zsp_data %A,& zsp_data %IA1, zsp_data %IA2,LDA,NDIAG) nullify(zsp_data %IA2) nnz = count( zsp_data %A.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored ! end if call set_infoa(zsp_data %INFOA,'n',nnz,ierr) call set_infoa(zsp_data %INFOA,'d',LDA,ierr) !row-dim of val call set_infoa(zsp_data %INFOA,'e',NDIAG,ierr) !col-dim of val end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_coo2dia end module mod_usconv_coo2dia SHAR_EOF fi # end of overwriting check if test -f 'usconv_csc2coo.f90' then echo shar: will not over-write existing file "'usconv_csc2coo.f90'" else cat << "SHAR_EOF" > 'usconv_csc2coo.f90' module mod_usconv_csc2coo use properties use mod_conv_tools use representation_of_data contains subroutine usconv_csc2coo(a,ierr) integer,intent(inout) :: a type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer ,intent(inout)::ierr integer :: res,s,rest ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='CSC') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='COO' s=size(isp_data %A) allocate(isp_data %IA2(s)) call PNTR_INV( isp_data %PE, isp_data %IA2) nullify(isp_data %PB) nullify(isp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='CSC') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='COO' s=size(ssp_data %A) allocate(ssp_data %IA2(s)) call PNTR_INV( ssp_data %PE, ssp_data %IA2) nullify(ssp_data %PB) nullify(ssp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='CSC') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='COO' s=size(dsp_data %A) allocate(dsp_data %IA2(s)) call PNTR_INV( dsp_data %PE, dsp_data %IA2) nullify(dsp_data %PB) nullify(dsp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='CSC') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='COO' s=size(csp_data %A) allocate(csp_data %IA2(s)) call PNTR_INV( csp_data %PE, csp_data %IA2) nullify(csp_data %PB) nullify(csp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='CSC') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='COO' s=size(zsp_data %A) allocate(zsp_data %IA2(s)) call PNTR_INV( zsp_data %PE, zsp_data %IA2) nullify(zsp_data %PB) nullify(zsp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_csc2coo end module mod_usconv_csc2coo SHAR_EOF fi # end of overwriting check if test -f 'usconv_csr2coo.f90' then echo shar: will not over-write existing file "'usconv_csr2coo.f90'" else cat << "SHAR_EOF" > 'usconv_csr2coo.f90' module mod_usconv_csr2coo use properties use mod_conv_tools use representation_of_data contains subroutine usconv_csr2coo(a,ierr) integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,s,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='CSR') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='COO' s=size(isp_data %A) allocate(isp_data %IA2(s)) isp_data %IA2= isp_data %IA1 call PNTR_INV( isp_data %PE, isp_data %IA1) nullify(isp_data %PB) nullify(isp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='CSR') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='COO' s=size(ssp_data %A) allocate(ssp_data %IA2(s)) ssp_data %IA2= ssp_data %IA1 call PNTR_INV( ssp_data %PE, ssp_data %IA1) nullify(ssp_data %PB) nullify(ssp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='CSR') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='COO' s=size(dsp_data %A) allocate(dsp_data %IA2(s)) dsp_data %IA2= dsp_data %IA1 call PNTR_INV( dsp_data %PE, dsp_data %IA1) nullify(dsp_data %PB) nullify(dsp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='CSR') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='COO' s=size(csp_data %A) allocate(csp_data %IA2(s)) csp_data %IA2= csp_data %IA1 call PNTR_INV( csp_data %PE, csp_data %IA1) nullify(csp_data %PB) nullify(csp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='CSR') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='COO' s=size(zsp_data %A) allocate(zsp_data %IA2(s)) zsp_data %IA2= zsp_data %IA1 call PNTR_INV( zsp_data %PE, zsp_data %IA1) nullify(zsp_data %PB) nullify(zsp_data %PE) end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_csr2coo end module mod_usconv_csr2coo SHAR_EOF fi # end of overwriting check if test -f 'usconv_dia2coo.f90' then echo shar: will not over-write existing file "'usconv_dia2coo.f90'" else cat << "SHAR_EOF" > 'usconv_dia2coo.f90' module mod_usconv_dia2coo use properties use mod_conv_tools use representation_of_data contains subroutine usconv_dia2coo(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,LDA,NNZ,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(isp_data %FIDA=='DIA') then call get_infoa(isp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then isp_data %FIDA='COO' allocate(isp_data %IA2(2)) call get_infoa(isp_data %INFOA ,'d',LDA,ierr) !row-dim of val call get_infoa(isp_data %INFOA ,'n',NNZ,ierr) call ipre_usconv_dia2coo (isp_data %A, isp_data %IA1, & isp_data %IA2,LDA,NNZ) end if else ierr = blas_error_param return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(ssp_data %FIDA=='DIA') then call get_infoa(ssp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then ssp_data %FIDA='COO' allocate(ssp_data %IA2(2)) call get_infoa(ssp_data %INFOA ,'d',LDA,ierr) !row-dim of val call get_infoa(ssp_data %INFOA ,'n',NNZ,ierr) call spre_usconv_dia2coo (ssp_data %A, ssp_data %IA1, & ssp_data %IA2,LDA,NNZ) end if else ierr = blas_error_param return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dsp_data %FIDA=='DIA') then call get_infoa(dsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dsp_data %FIDA='COO' allocate(dsp_data %IA2(2)) call get_infoa(dsp_data %INFOA ,'d',LDA,ierr) !row-dim of val call get_infoa(dsp_data %INFOA ,'n',NNZ,ierr) call dpre_usconv_dia2coo (dsp_data %A, dsp_data %IA1, & dsp_data %IA2,LDA,NNZ) end if else ierr = blas_error_param return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(csp_data %FIDA=='DIA') then call get_infoa(csp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then csp_data %FIDA='COO' allocate(csp_data %IA2(2)) call get_infoa(csp_data %INFOA ,'d',LDA,ierr) !row-dim of val call get_infoa(csp_data %INFOA ,'n',NNZ,ierr) call cpre_usconv_dia2coo (csp_data %A, csp_data %IA1, & csp_data %IA2,LDA,NNZ) end if else ierr = blas_error_param return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(zsp_data %FIDA=='DIA') then call get_infoa(zsp_data %INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then zsp_data %FIDA='COO' allocate(zsp_data %IA2(2)) call get_infoa(zsp_data %INFOA ,'d',LDA,ierr) !row-dim of val call get_infoa(zsp_data %INFOA ,'n',NNZ,ierr) call zpre_usconv_dia2coo (zsp_data %A, zsp_data %IA1, & zsp_data %IA2,LDA,NNZ) end if else ierr = blas_error_param return end if ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_dia2coo end module mod_usconv_dia2coo SHAR_EOF fi # end of overwriting check if test -f 'uscr.f90' then echo shar: will not over-write existing file "'uscr.f90'" else cat << "SHAR_EOF" > 'uscr.f90' module mod_uscr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 29.2.00 ! ! Description : JUST A CONTAINER FOR ALL mod_uscr_XXX ! ********************************************************************** use mod_uscr_coo use mod_uscr_csc use mod_uscr_csr use mod_uscr_dia use mod_uscr_bco use mod_uscr_bsr use mod_uscr_bsc use mod_uscr_bdi use mod_uscr_vbr end module mod_uscr SHAR_EOF fi # end of overwriting check if test -f 'uscr_bco.f90' then echo shar: will not over-write existing file "'uscr_bco.f90'" else cat << "SHAR_EOF" > 'uscr_bco.f90' module mod_uscr_bco ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'BCO'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_bco module procedure iuscr_bco module procedure suscr_bco module procedure duscr_bco module procedure cuscr_bco module procedure zuscr_bco end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_bco (m,n,val,bindx,bjndx,bnnz,mb,kb,lb, & prpty,istat,a) implicit none integer, intent(in) :: m,n,bnnz,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bjndx integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BCO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) call set_infoa(dsp_data%INFOA,'n',bnnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((bnnz.ne.size(bindx)).or.(bnnz.ne.size(bjndx)).or.& (m.ne.mb*lb).or.(n.ne.kb*lb).or.(bnnz*lb*lb.ne.size(val)).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (minval(bjndx).lt.base).or.(maxval(bjndx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => bjndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(bjndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = bjndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_bco ! ********************************************************************** ! ********************************************************************** subroutine suscr_bco (m,n,val,bindx,bjndx,bnnz,mb,kb,lb, & prpty,istat,a) implicit none integer, intent(in) :: m,n,bnnz,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bjndx real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BCO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) call set_infoa(dsp_data%INFOA,'n',bnnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((bnnz.ne.size(bindx)).or.(bnnz.ne.size(bjndx)).or.& (m.ne.mb*lb).or.(n.ne.kb*lb).or.(bnnz*lb*lb.ne.size(val)).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (minval(bjndx).lt.base).or.(maxval(bjndx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => bjndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(bjndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = bjndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_bco ! ********************************************************************** ! ********************************************************************** subroutine duscr_bco (m,n,val,bindx,bjndx,bnnz,mb,kb,lb, & prpty,istat,a) implicit none integer, intent(in) :: m,n,bnnz,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bjndx real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BCO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) call set_infoa(dsp_data%INFOA,'n',bnnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((bnnz.ne.size(bindx)).or.(bnnz.ne.size(bjndx)).or.& (m.ne.mb*lb).or.(n.ne.kb*lb).or.(bnnz*lb*lb.ne.size(val)).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (minval(bjndx).lt.base).or.(maxval(bjndx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => bjndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(bjndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = bjndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_bco ! ********************************************************************** ! ********************************************************************** subroutine cuscr_bco (m,n,val,bindx,bjndx,bnnz,mb,kb,lb, & prpty,istat,a) implicit none integer, intent(in) :: m,n,bnnz,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bjndx complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BCO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) call set_infoa(dsp_data%INFOA,'n',bnnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((bnnz.ne.size(bindx)).or.(bnnz.ne.size(bjndx)).or.& (m.ne.mb*lb).or.(n.ne.kb*lb).or.(bnnz*lb*lb.ne.size(val)).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (minval(bjndx).lt.base).or.(maxval(bjndx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => bjndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(bjndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = bjndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_bco ! ********************************************************************** ! ********************************************************************** subroutine zuscr_bco (m,n,val,bindx,bjndx,bnnz,mb,kb,lb, & prpty,istat,a) implicit none integer, intent(in) :: m,n,bnnz,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bjndx complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BCO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) call set_infoa(dsp_data%INFOA,'n',bnnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((bnnz.ne.size(bindx)).or.(bnnz.ne.size(bjndx)).or.& (m.ne.mb*lb).or.(n.ne.kb*lb).or.(bnnz*lb*lb.ne.size(val)).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (minval(bjndx).lt.base).or.(maxval(bjndx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => bjndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(bjndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = bjndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_bco ! ********************************************************************** ! ********************************************************************** end module mod_uscr_bco SHAR_EOF fi # end of overwriting check if test -f 'uscr_bdi.f90' then echo shar: will not over-write existing file "'uscr_bdi.f90'" else cat << "SHAR_EOF" > 'uscr_bdi.f90' module mod_uscr_bdi ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'BDI'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_bdi module procedure iuscr_bdi module procedure suscr_bdi module procedure duscr_bdi module procedure cuscr_bdi module procedure zuscr_bdi end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_bdi (m,n,val,blda,ibdiag,nbdiag,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,blda,nbdiag,mb,kb,lb,prpty integer, dimension(:), intent(inout), target :: ibdiag integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((nbdiag.ne.size(ibdiag)).or.(blda*nbdiag*lb*lb.ne.size(val))& .or.(maxval(ibdiag).gt.kb).or.(minval(ibdiag).lt.-mb).or.& (blda.ne.min(mb,kb))) then ierr = blas_error_param return end if call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BDI' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.blda*nbdiag*lb*lb*0.5) then ! Warning Many zeros stored ! end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',blda,ierr) !blocks per diagonal call set_infoa(dsp_data%INFOA,'g',nbdiag,ierr) !no of diagonals if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => ibdiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(ibdiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = ibdiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_bdi ! ********************************************************************** ! ********************************************************************** subroutine suscr_bdi (m,n,val,blda,ibdiag,nbdiag,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,blda,nbdiag,mb,kb,lb,prpty integer, dimension(:), intent(inout), target :: ibdiag real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((nbdiag.ne.size(ibdiag)).or.(blda*nbdiag*lb*lb.ne.size(val))& .or.(maxval(ibdiag).gt.kb).or.(minval(ibdiag).lt.-mb).or.& (blda.ne.min(mb,kb))) then ierr = blas_error_param return end if call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BDI' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.blda*nbdiag*lb*lb*0.5) then ! Warning Many zeros stored ! end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',blda,ierr) !blocks per diagonal call set_infoa(dsp_data%INFOA,'g',nbdiag,ierr) !no of diagonals if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => ibdiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(ibdiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = ibdiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_bdi ! ********************************************************************** ! ********************************************************************** subroutine duscr_bdi (m,n,val,blda,ibdiag,nbdiag,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,blda,nbdiag,mb,kb,lb,prpty integer, dimension(:), intent(inout), target :: ibdiag real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((nbdiag.ne.size(ibdiag)).or.(blda*nbdiag*lb*lb.ne.size(val))& .or.(maxval(ibdiag).gt.kb).or.(minval(ibdiag).lt.-mb).or.& (blda.ne.min(mb,kb))) then ierr = blas_error_param return end if call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BDI' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.blda*nbdiag*lb*lb*0.5) then ! Warning Many zeros stored ! end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',blda,ierr) !blocks per diagonal call set_infoa(dsp_data%INFOA,'g',nbdiag,ierr) !no of diagonals if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => ibdiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(ibdiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = ibdiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_bdi ! ********************************************************************** ! ********************************************************************** subroutine cuscr_bdi (m,n,val,blda,ibdiag,nbdiag,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,blda,nbdiag,mb,kb,lb,prpty integer, dimension(:), intent(inout), target :: ibdiag complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((nbdiag.ne.size(ibdiag)).or.(blda*nbdiag*lb*lb.ne.size(val))& .or.(maxval(ibdiag).gt.kb).or.(minval(ibdiag).lt.-mb).or.& (blda.ne.min(mb,kb))) then ierr = blas_error_param return end if call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BDI' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.blda*nbdiag*lb*lb*0.5) then ! Warning Many zeros stored ! end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',blda,ierr) !blocks per diagonal call set_infoa(dsp_data%INFOA,'g',nbdiag,ierr) !no of diagonals if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => ibdiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(ibdiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = ibdiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_bdi ! ********************************************************************** ! ********************************************************************** subroutine zuscr_bdi (m,n,val,blda,ibdiag,nbdiag,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,blda,nbdiag,mb,kb,lb,prpty integer, dimension(:), intent(inout), target :: ibdiag complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((nbdiag.ne.size(ibdiag)).or.(blda*nbdiag*lb*lb.ne.size(val))& .or.(maxval(ibdiag).gt.kb).or.(minval(ibdiag).lt.-mb).or.& (blda.ne.min(mb,kb))) then ierr = blas_error_param return end if call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BDI' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.blda*nbdiag*lb*lb*0.5) then ! Warning Many zeros stored ! end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',blda,ierr) !blocks per diagonal call set_infoa(dsp_data%INFOA,'g',nbdiag,ierr) !no of diagonals if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => ibdiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(ibdiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = ibdiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_bdi ! ********************************************************************** ! ********************************************************************** end module mod_uscr_bdi SHAR_EOF fi # end of overwriting check if test -f 'uscr_begin.f90' then echo shar: will not over-write existing file "'uscr_begin.f90'" else cat << "SHAR_EOF" > 'uscr_begin.f90' module mod_uscr_begin use mod_INSERTING implicit none contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_begin (m,n,a,istat) implicit none integer ,intent(in) ::m,n integer ,intent(out)::a,istat integer ::nmb,mb type(i_matrix ),pointer :: ipmatrix mb=1 istat = -1 if((m.le.0).or.(n.le.0)) then istat = blas_error_param return else call new_i_matrix (nmb,mb,istat) if (istat.ne.0) then istat = blas_error_memalloc return end if call access_matrix(ipmatrix ,nmb,istat) if (istat.ne.0) then istat = blas_error_param return end if ipmatrix %DIM(1)=m !nb_of_rows ipmatrix %DIM(2)=n !nb_of_cols ipmatrix %format='normal' a=nmb end if end subroutine iuscr_begin ! ********************************************************************** ! ********************************************************************** subroutine suscr_begin (m,n,a,istat) implicit none integer ,intent(in) ::m,n integer ,intent(out)::a,istat integer ::nmb,mb type(s_matrix ),pointer :: spmatrix mb=1 istat = -1 if((m.le.0).or.(n.le.0)) then istat = blas_error_param return else call new_s_matrix (nmb,mb,istat) if (istat.ne.0) then istat = blas_error_memalloc return end if call access_matrix(spmatrix ,nmb,istat) if (istat.ne.0) then istat = blas_error_param return end if spmatrix %DIM(1)=m !nb_of_rows spmatrix %DIM(2)=n !nb_of_cols spmatrix %format='normal' a=nmb end if end subroutine suscr_begin ! ********************************************************************** ! ********************************************************************** subroutine duscr_begin (m,n,a,istat) implicit none integer ,intent(in) ::m,n integer ,intent(out)::a,istat integer ::nmb,mb type(d_matrix ),pointer :: dpmatrix mb=1 istat = -1 if((m.le.0).or.(n.le.0)) then istat = blas_error_param return else call new_d_matrix (nmb,mb,istat) if (istat.ne.0) then istat = blas_error_memalloc return end if call access_matrix(dpmatrix ,nmb,istat) if (istat.ne.0) then istat = blas_error_param return end if dpmatrix %DIM(1)=m !nb_of_rows dpmatrix %DIM(2)=n !nb_of_cols dpmatrix %format='normal' a=nmb end if end subroutine duscr_begin ! ********************************************************************** ! ********************************************************************** subroutine cuscr_begin (m,n,a,istat) implicit none integer ,intent(in) ::m,n integer ,intent(out)::a,istat integer ::nmb,mb type(c_matrix ),pointer :: cpmatrix mb=1 istat = -1 if((m.le.0).or.(n.le.0)) then istat = blas_error_param return else call new_c_matrix (nmb,mb,istat) if (istat.ne.0) then istat = blas_error_memalloc return end if call access_matrix(cpmatrix ,nmb,istat) if (istat.ne.0) then istat = blas_error_param return end if cpmatrix %DIM(1)=m !nb_of_rows cpmatrix %DIM(2)=n !nb_of_cols cpmatrix %format='normal' a=nmb end if end subroutine cuscr_begin ! ********************************************************************** ! ********************************************************************** subroutine zuscr_begin (m,n,a,istat) implicit none integer ,intent(in) ::m,n integer ,intent(out)::a,istat integer ::nmb,mb type(z_matrix ),pointer :: zpmatrix mb=1 istat = -1 if((m.le.0).or.(n.le.0)) then istat = blas_error_param return else call new_z_matrix (nmb,mb,istat) if (istat.ne.0) then istat = blas_error_memalloc return end if call access_matrix(zpmatrix ,nmb,istat) if (istat.ne.0) then istat = blas_error_param return end if zpmatrix %DIM(1)=m !nb_of_rows zpmatrix %DIM(2)=n !nb_of_cols zpmatrix %format='normal' a=nmb end if end subroutine zuscr_begin ! ********************************************************************** ! ********************************************************************** end module mod_uscr_begin SHAR_EOF fi # end of overwriting check if test -f 'uscr_block_begin.f90' then echo shar: will not over-write existing file "'uscr_block_begin.f90'" else cat << "SHAR_EOF" > 'uscr_block_begin.f90' module mod_uscr_block_begin use mod_INSERTING use properties implicit none contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb,k,l integer ,intent(out)::a,istat integer ::nmb,m type(i_matrix ),pointer :: ipmatrix m=1 istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_i_matrix (nmb,m,istat) if (istat.ne.0) return call access_matrix(ipmatrix ,nmb, istat) if (istat.ne.0) return ipmatrix %DIM(3)=Mb !nb_of_block_rows ipmatrix %DIM(4)=Nb !nb_of_block_cols ipmatrix %DIM(5)=k !nb_of_rows_in_block ipmatrix %DIM(6)=l !nb_of_cols_in_block ipmatrix %format='block' a=nmb end if istat = 0 end subroutine iuscr_block_begin ! ********************************************************************** ! ********************************************************************** subroutine suscr_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb,k,l integer ,intent(out)::a,istat integer ::nmb,m type(s_matrix ),pointer :: spmatrix m=1 istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_s_matrix (nmb,m,istat) if (istat.ne.0) return call access_matrix(spmatrix ,nmb, istat) if (istat.ne.0) return spmatrix %DIM(3)=Mb !nb_of_block_rows spmatrix %DIM(4)=Nb !nb_of_block_cols spmatrix %DIM(5)=k !nb_of_rows_in_block spmatrix %DIM(6)=l !nb_of_cols_in_block spmatrix %format='block' a=nmb end if istat = 0 end subroutine suscr_block_begin ! ********************************************************************** ! ********************************************************************** subroutine duscr_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb,k,l integer ,intent(out)::a,istat integer ::nmb,m type(d_matrix ),pointer :: dpmatrix m=1 istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_d_matrix (nmb,m,istat) if (istat.ne.0) return call access_matrix(dpmatrix ,nmb, istat) if (istat.ne.0) return dpmatrix %DIM(3)=Mb !nb_of_block_rows dpmatrix %DIM(4)=Nb !nb_of_block_cols dpmatrix %DIM(5)=k !nb_of_rows_in_block dpmatrix %DIM(6)=l !nb_of_cols_in_block dpmatrix %format='block' a=nmb end if istat = 0 end subroutine duscr_block_begin ! ********************************************************************** ! ********************************************************************** subroutine cuscr_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb,k,l integer ,intent(out)::a,istat integer ::nmb,m type(c_matrix ),pointer :: cpmatrix m=1 istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_c_matrix (nmb,m,istat) if (istat.ne.0) return call access_matrix(cpmatrix ,nmb, istat) if (istat.ne.0) return cpmatrix %DIM(3)=Mb !nb_of_block_rows cpmatrix %DIM(4)=Nb !nb_of_block_cols cpmatrix %DIM(5)=k !nb_of_rows_in_block cpmatrix %DIM(6)=l !nb_of_cols_in_block cpmatrix %format='block' a=nmb end if istat = 0 end subroutine cuscr_block_begin ! ********************************************************************** ! ********************************************************************** subroutine zuscr_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb,k,l integer ,intent(out)::a,istat integer ::nmb,m type(z_matrix ),pointer :: zpmatrix m=1 istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_z_matrix (nmb,m,istat) if (istat.ne.0) return call access_matrix(zpmatrix ,nmb, istat) if (istat.ne.0) return zpmatrix %DIM(3)=Mb !nb_of_block_rows zpmatrix %DIM(4)=Nb !nb_of_block_cols zpmatrix %DIM(5)=k !nb_of_rows_in_block zpmatrix %DIM(6)=l !nb_of_cols_in_block zpmatrix %format='block' a=nmb end if istat = 0 end subroutine zuscr_block_begin ! ********************************************************************** ! ********************************************************************** end module mod_uscr_block_begin SHAR_EOF fi # end of overwriting check if test -f 'uscr_bsc.f90' then echo shar: will not over-write existing file "'uscr_bsc.f90'" else cat << "SHAR_EOF" > 'uscr_bsc.f90' module mod_uscr_bsc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'BSC'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_bsc module procedure iuscr_bsc module procedure suscr_bsc module procedure duscr_bsc module procedure cuscr_bsc module procedure zuscr_bsc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_bsc (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((kb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (kb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_bsc ! ********************************************************************** ! ********************************************************************** subroutine suscr_bsc (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((kb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (kb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_bsc ! ********************************************************************** ! ********************************************************************** subroutine duscr_bsc (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((kb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (kb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_bsc ! ********************************************************************** ! ********************************************************************** subroutine cuscr_bsc (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((kb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (kb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_bsc ! ********************************************************************** ! ********************************************************************** subroutine zuscr_bsc (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((kb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (kb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_bsc ! ********************************************************************** ! ********************************************************************** end module mod_uscr_bsc SHAR_EOF fi # end of overwriting check if test -f 'uscr_bsr.f90' then echo shar: will not over-write existing file "'uscr_bsr.f90'" else cat << "SHAR_EOF" > 'uscr_bsr.f90' module mod_uscr_bsr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'BSR'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_bsr module procedure iuscr_bsr module procedure suscr_bsr module procedure duscr_bsr module procedure cuscr_bsr module procedure zuscr_bsr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_bsr (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base).or.& (mb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_bsr ! ********************************************************************** ! ********************************************************************** subroutine suscr_bsr (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base).or.& (mb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_bsr ! ********************************************************************** ! ********************************************************************** subroutine duscr_bsr (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base).or.& (mb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_bsr ! ********************************************************************** ! ********************************************************************** subroutine cuscr_bsr (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base).or.& (mb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_bsr ! ********************************************************************** ! ********************************************************************** subroutine zuscr_bsr (m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base).or.& (mb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_bsr ! ********************************************************************** ! ********************************************************************** end module mod_uscr_bsr SHAR_EOF fi # end of overwriting check if test -f 'uscr_coo.f90' then echo shar: will not over-write existing file "'uscr_coo.f90'" else cat << "SHAR_EOF" > 'uscr_coo.f90' module mod_uscr_coo ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'COO'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_coo module procedure iuscr_coo module procedure suscr_coo module procedure duscr_coo module procedure cuscr_coo module procedure zuscr_coo end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_coo (m,n,val,indx,jndx,nnz,prpty,istat,a) implicit none integer, intent(in) :: m,n,nnz,prpty integer, dimension(:), intent(inout),target :: indx,jndx integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options,base logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'COO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if((nnz.ne.size(indx)).or.(nnz.ne.size(jndx)).or.& (nnz.ne.size(val)).or.(minval(indx).lt.base).or.& (minval(jndx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (maxval(jndx).gt.n-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%IA2 => jndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%IA2(size(jndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%IA2 = jndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_coo ! ********************************************************************** ! ********************************************************************** subroutine suscr_coo (m,n,val,indx,jndx,nnz,prpty,istat,a) implicit none integer, intent(in) :: m,n,nnz,prpty integer, dimension(:), intent(inout),target :: indx,jndx real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options,base logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'COO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if((nnz.ne.size(indx)).or.(nnz.ne.size(jndx)).or.& (nnz.ne.size(val)).or.(minval(indx).lt.base).or.& (minval(jndx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (maxval(jndx).gt.n-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%IA2 => jndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%IA2(size(jndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%IA2 = jndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_coo ! ********************************************************************** ! ********************************************************************** subroutine duscr_coo (m,n,val,indx,jndx,nnz,prpty,istat,a) implicit none integer, intent(in) :: m,n,nnz,prpty integer, dimension(:), intent(inout),target :: indx,jndx real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options,base logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'COO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if((nnz.ne.size(indx)).or.(nnz.ne.size(jndx)).or.& (nnz.ne.size(val)).or.(minval(indx).lt.base).or.& (minval(jndx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (maxval(jndx).gt.n-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%IA2 => jndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%IA2(size(jndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%IA2 = jndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_coo ! ********************************************************************** ! ********************************************************************** subroutine cuscr_coo (m,n,val,indx,jndx,nnz,prpty,istat,a) implicit none integer, intent(in) :: m,n,nnz,prpty integer, dimension(:), intent(inout),target :: indx,jndx complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options,base logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'COO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if((nnz.ne.size(indx)).or.(nnz.ne.size(jndx)).or.& (nnz.ne.size(val)).or.(minval(indx).lt.base).or.& (minval(jndx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (maxval(jndx).gt.n-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%IA2 => jndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%IA2(size(jndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%IA2 = jndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_coo ! ********************************************************************** ! ********************************************************************** subroutine zuscr_coo (m,n,val,indx,jndx,nnz,prpty,istat,a) implicit none integer, intent(in) :: m,n,nnz,prpty integer, dimension(:), intent(inout),target :: indx,jndx complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options,base logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'COO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if((nnz.ne.size(indx)).or.(nnz.ne.size(jndx)).or.& (nnz.ne.size(val)).or.(minval(indx).lt.base).or.& (minval(jndx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (maxval(jndx).gt.n-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%IA2 => jndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%IA2(size(jndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%IA2 = jndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_coo ! ********************************************************************** ! ********************************************************************** end module mod_uscr_coo SHAR_EOF fi # end of overwriting check if test -f 'uscr_csc.f90' then echo shar: will not over-write existing file "'uscr_csc.f90'" else cat << "SHAR_EOF" > 'uscr_csc.f90' module mod_uscr_csc ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'CSC'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_csc module procedure iuscr_csc module procedure suscr_csc module procedure duscr_csc module procedure cuscr_csc module procedure zuscr_csc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_csc (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(n.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (n.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_csc ! ********************************************************************** ! ********************************************************************** subroutine suscr_csc (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(n.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (n.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_csc ! ********************************************************************** ! ********************************************************************** subroutine duscr_csc (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(n.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (n.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_csc ! ********************************************************************** ! ********************************************************************** subroutine cuscr_csc (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(n.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (n.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_csc ! ********************************************************************** ! ********************************************************************** subroutine zuscr_csc (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(n.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (n.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_csc ! ********************************************************************** ! ********************************************************************** end module mod_uscr_csc SHAR_EOF fi # end of overwriting check if test -f 'uscr_csr.f90' then echo shar: will not over-write existing file "'uscr_csr.f90'" else cat << "SHAR_EOF" > 'uscr_csr.f90' module mod_uscr_csr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'CSR'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_csr module procedure iuscr_csr module procedure suscr_csr module procedure duscr_csr module procedure cuscr_csr module procedure zuscr_csr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_csr (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(m.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.n-1+base).or.& (m.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_csr ! ********************************************************************** ! ********************************************************************** subroutine suscr_csr (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(m.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.n-1+base).or.& (m.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_csr ! ********************************************************************** ! ********************************************************************** subroutine duscr_csr (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(m.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.n-1+base).or.& (m.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_csr ! ********************************************************************** ! ********************************************************************** subroutine cuscr_csr (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(m.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.n-1+base).or.& (m.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_csr ! ********************************************************************** ! ********************************************************************** subroutine zuscr_csr (m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(m.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.n-1+base).or.& (m.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_csr ! ********************************************************************** ! ********************************************************************** end module mod_uscr_csr SHAR_EOF fi # end of overwriting check if test -f 'uscr_dia.f90' then echo shar: will not over-write existing file "'uscr_dia.f90'" else cat << "SHAR_EOF" > 'uscr_dia.f90' module mod_uscr_dia ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'DIA'-FORMAT ! ********************************************************************** use representation_of_data use properties implicit none interface uscr_dia module procedure iuscr_dia module procedure suscr_dia module procedure duscr_dia module procedure cuscr_dia module procedure zuscr_dia end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_dia (m,n,val,lda,idiag,ndiag,prpty,istat,a) implicit none integer, intent(in) :: m,n,lda,ndiag,prpty integer, dimension(:), intent(inout),target :: idiag integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr,nnz,options,base logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((ndiag.ne.size(idiag)).or.(lda*ndiag.ne.size(val)).or.& (maxval(idiag).gt.n).or.(minval(idiag).lt.-m).or.& (lda.ne.min(m,n))) then ierr = blas_error_param return end if call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'DIA' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lda,ierr) !row-dim of val call set_infoa(dsp_data%INFOA,'e',ndiag,ierr) !col-dim of val if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => idiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(idiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = idiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_dia ! ********************************************************************** ! ********************************************************************** subroutine suscr_dia (m,n,val,lda,idiag,ndiag,prpty,istat,a) implicit none integer, intent(in) :: m,n,lda,ndiag,prpty integer, dimension(:), intent(inout),target :: idiag real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr,nnz,options,base logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((ndiag.ne.size(idiag)).or.(lda*ndiag.ne.size(val)).or.& (maxval(idiag).gt.n).or.(minval(idiag).lt.-m).or.& (lda.ne.min(m,n))) then ierr = blas_error_param return end if call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'DIA' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lda,ierr) !row-dim of val call set_infoa(dsp_data%INFOA,'e',ndiag,ierr) !col-dim of val if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => idiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(idiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = idiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_dia ! ********************************************************************** ! ********************************************************************** subroutine duscr_dia (m,n,val,lda,idiag,ndiag,prpty,istat,a) implicit none integer, intent(in) :: m,n,lda,ndiag,prpty integer, dimension(:), intent(inout),target :: idiag real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr,nnz,options,base logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((ndiag.ne.size(idiag)).or.(lda*ndiag.ne.size(val)).or.& (maxval(idiag).gt.n).or.(minval(idiag).lt.-m).or.& (lda.ne.min(m,n))) then ierr = blas_error_param return end if call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'DIA' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lda,ierr) !row-dim of val call set_infoa(dsp_data%INFOA,'e',ndiag,ierr) !col-dim of val if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => idiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(idiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = idiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_dia ! ********************************************************************** ! ********************************************************************** subroutine cuscr_dia (m,n,val,lda,idiag,ndiag,prpty,istat,a) implicit none integer, intent(in) :: m,n,lda,ndiag,prpty integer, dimension(:), intent(inout),target :: idiag complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr,nnz,options,base logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((ndiag.ne.size(idiag)).or.(lda*ndiag.ne.size(val)).or.& (maxval(idiag).gt.n).or.(minval(idiag).lt.-m).or.& (lda.ne.min(m,n))) then ierr = blas_error_param return end if call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'DIA' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lda,ierr) !row-dim of val call set_infoa(dsp_data%INFOA,'e',ndiag,ierr) !col-dim of val if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => idiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(idiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = idiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_dia ! ********************************************************************** ! ********************************************************************** subroutine zuscr_dia (m,n,val,lda,idiag,ndiag,prpty,istat,a) implicit none integer, intent(in) :: m,n,lda,ndiag,prpty integer, dimension(:), intent(inout),target :: idiag complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr,nnz,options,base logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((ndiag.ne.size(idiag)).or.(lda*ndiag.ne.size(val)).or.& (maxval(idiag).gt.n).or.(minval(idiag).lt.-m).or.& (lda.ne.min(m,n))) then ierr = blas_error_param return end if call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'DIA' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lda,ierr) !row-dim of val call set_infoa(dsp_data%INFOA,'e',ndiag,ierr) !col-dim of val if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => idiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(idiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = idiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_dia ! ********************************************************************** ! ********************************************************************** end module mod_uscr_dia SHAR_EOF fi # end of overwriting check if test -f 'uscr_end.f90' then echo shar: will not over-write existing file "'uscr_end.f90'" else cat << "SHAR_EOF" > 'uscr_end.f90' module mod_uscr_end use mod_INSERTING use mod_INS_ROUTINER use properties contains subroutine uscr_end(a,istat) implicit none integer ,intent(inout)::a,istat integer::prpty,rest,b type(i_matrix),pointer ::ipmatrix type(d_matrix),pointer ::dpmatrix type(s_matrix),pointer ::spmatrix type(c_matrix),pointer ::cpmatrix type(z_matrix),pointer ::zpmatrix b=-a rest = modulo(b,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** istat=-1 call access_matrix(ipmatrix ,a,istat) if(istat.ne.0) return prpty= ipmatrix %property select case(ipmatrix %format) case('block') call iuscr_blockend (a,prpty,istat) if(istat.ne.0) return case('vblock') call iuscr_varend (a,prpty,istat) if(istat.ne.0) return case('normal') call iuscr_normend (a,prpty,istat) if(istat.ne.0) return case default istat = blas_error_param return end select !!*************************************************************************** ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** istat=-1 call access_matrix(spmatrix ,a,istat) if(istat.ne.0) return prpty= spmatrix %property select case(spmatrix %format) case('block') call suscr_blockend (a,prpty,istat) if(istat.ne.0) return case('vblock') call suscr_varend (a,prpty,istat) if(istat.ne.0) return case('normal') call suscr_normend (a,prpty,istat) if(istat.ne.0) return case default istat = blas_error_param return end select ! ********************************************************************** !!*************************************************************************** case(DSP_MATRIX) ! ********************************************************************** istat=-1 call access_matrix(dpmatrix ,a,istat) if(istat.ne.0) return prpty= dpmatrix %property select case(dpmatrix %format) case('block') call duscr_blockend (a,prpty,istat) if(istat.ne.0) return case('vblock') call duscr_varend (a,prpty,istat) if(istat.ne.0) return case('normal') call duscr_normend (a,prpty,istat) if(istat.ne.0) return case default istat = blas_error_param return end select ! ********************************************************************** !!*************************************************************************** case(CSP_MATRIX) ! ********************************************************************** istat=-1 call access_matrix(cpmatrix ,a,istat) if(istat.ne.0) return prpty= cpmatrix %property select case(cpmatrix %format) case('block') call cuscr_blockend (a,prpty,istat) if(istat.ne.0) return case('vblock') call cuscr_varend (a,prpty,istat) if(istat.ne.0) return case('normal') call cuscr_normend (a,prpty,istat) if(istat.ne.0) return case default istat = blas_error_param return end select ! ********************************************************************** !!*************************************************************************** case(ZSP_MATRIX) ! ********************************************************************** istat=-1 call access_matrix(zpmatrix ,a,istat) if(istat.ne.0) return prpty= zpmatrix %property select case(zpmatrix %format) case('block') call zuscr_blockend (a,prpty,istat) if(istat.ne.0) return case('vblock') call zuscr_varend (a,prpty,istat) if(istat.ne.0) return case('normal') call zuscr_normend (a,prpty,istat) if(istat.ne.0) return case default istat = blas_error_param return end select ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** case default istat = blas_error_param return end select end subroutine uscr_end end module mod_uscr_end SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_block.f90' then echo shar: will not over-write existing file "'uscr_insert_block.f90'" else cat << "SHAR_EOF" > 'uscr_insert_block.f90' module mod_uscr_insert_block use blas_sparse_namedconstants use mod_INSERTING use mod_INS_ROUTINER interface uscr_insert_block module procedure iuscr_insert_block module procedure suscr_insert_block module procedure duscr_insert_block module procedure cuscr_insert_block module procedure zuscr_insert_block end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine iuscr_insert_block (a,val,bi,bj,istat) implicit none integer ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a,bi,bj integer,intent(out)::istat type(i_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if(istat.ne.0) return select case(pmatrix%format) case('block') call iINS_block (pmatrix,val,bi,bj,istat) case('vblock') call iINS_varblock (pmatrix,val,bi,bj,istat) case default istat = blas_error_param return end select end subroutine iuscr_insert_block ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine suscr_insert_block (a,val,bi,bj,istat) implicit none real(KIND=sp) ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a,bi,bj integer,intent(out)::istat type(s_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if(istat.ne.0) return select case(pmatrix%format) case('block') call sINS_block (pmatrix,val,bi,bj,istat) case('vblock') call sINS_varblock (pmatrix,val,bi,bj,istat) case default istat = blas_error_param return end select end subroutine suscr_insert_block ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine duscr_insert_block (a,val,bi,bj,istat) implicit none real(KIND=dp) ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a,bi,bj integer,intent(out)::istat type(d_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if(istat.ne.0) return select case(pmatrix%format) case('block') call dINS_block (pmatrix,val,bi,bj,istat) case('vblock') call dINS_varblock (pmatrix,val,bi,bj,istat) case default istat = blas_error_param return end select end subroutine duscr_insert_block ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine cuscr_insert_block (a,val,bi,bj,istat) implicit none complex(KIND=sp) ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a,bi,bj integer,intent(out)::istat type(c_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if(istat.ne.0) return select case(pmatrix%format) case('block') call cINS_block (pmatrix,val,bi,bj,istat) case('vblock') call cINS_varblock (pmatrix,val,bi,bj,istat) case default istat = blas_error_param return end select end subroutine cuscr_insert_block ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine zuscr_insert_block (a,val,bi,bj,istat) implicit none complex(KIND=dp) ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a,bi,bj integer,intent(out)::istat type(z_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if(istat.ne.0) return select case(pmatrix%format) case('block') call zINS_block (pmatrix,val,bi,bj,istat) case('vblock') call zINS_varblock (pmatrix,val,bi,bj,istat) case default istat = blas_error_param return end select end subroutine zuscr_insert_block ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_block SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_clique.f90' then echo shar: will not over-write existing file "'uscr_insert_clique.f90'" else cat << "SHAR_EOF" > 'uscr_insert_clique.f90' module mod_uscr_insert_clique use blas_sparse_namedconstants use mod_uscr_insert_entry interface uscr_insert_clique module procedure iuscr_insert_clique module procedure suscr_insert_clique module procedure duscr_insert_clique module procedure cuscr_insert_clique module procedure zuscr_insert_clique end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine iuscr_insert_clique (a,val,indx,jndx,istat) implicit none integer ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx,jndx integer ::i,j,s_row,s_col istat=-1 s_row=size(indx) s_col=size(jndx) do j=1,s_col do i=1,s_row call iuscr_insert_entry (a,val(i,j),& indx(i),jndx(j),istat) if(istat.ne.0) return end do end do end subroutine iuscr_insert_clique ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine suscr_insert_clique (a,val,indx,jndx,istat) implicit none real(KIND=sp) ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx,jndx integer ::i,j,s_row,s_col istat=-1 s_row=size(indx) s_col=size(jndx) do j=1,s_col do i=1,s_row call suscr_insert_entry (a,val(i,j),& indx(i),jndx(j),istat) if(istat.ne.0) return end do end do end subroutine suscr_insert_clique ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine duscr_insert_clique (a,val,indx,jndx,istat) implicit none real(KIND=dp) ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx,jndx integer ::i,j,s_row,s_col istat=-1 s_row=size(indx) s_col=size(jndx) do j=1,s_col do i=1,s_row call duscr_insert_entry (a,val(i,j),& indx(i),jndx(j),istat) if(istat.ne.0) return end do end do end subroutine duscr_insert_clique ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine cuscr_insert_clique (a,val,indx,jndx,istat) implicit none complex(KIND=sp) ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx,jndx integer ::i,j,s_row,s_col istat=-1 s_row=size(indx) s_col=size(jndx) do j=1,s_col do i=1,s_row call cuscr_insert_entry (a,val(i,j),& indx(i),jndx(j),istat) if(istat.ne.0) return end do end do end subroutine cuscr_insert_clique ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine zuscr_insert_clique (a,val,indx,jndx,istat) implicit none complex(KIND=dp) ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx,jndx integer ::i,j,s_row,s_col istat=-1 s_row=size(indx) s_col=size(jndx) do j=1,s_col do i=1,s_row call zuscr_insert_entry (a,val(i,j),& indx(i),jndx(j),istat) if(istat.ne.0) return end do end do end subroutine zuscr_insert_clique ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_clique SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_col.f90' then echo shar: will not over-write existing file "'uscr_insert_col.f90'" else cat << "SHAR_EOF" > 'uscr_insert_col.f90' module mod_uscr_insert_col use blas_sparse_namedconstants use mod_uscr_insert_entry interface uscr_insert_col module procedure iuscr_insert_col module procedure suscr_insert_col module procedure duscr_insert_col module procedure cuscr_insert_col module procedure zuscr_insert_col end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine iuscr_insert_col (a,j,val,indx,istat) implicit none integer ,dimension(:),intent(in) ::val integer ,intent(in) ::a,j integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx integer ::i,s istat=-1 s=size(val) do i=1,s call iuscr_insert_entry (a,val(i),indx(i),j,istat) if(istat.ne.0) return end do end subroutine iuscr_insert_col ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine suscr_insert_col (a,j,val,indx,istat) implicit none real(KIND=sp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a,j integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx integer ::i,s istat=-1 s=size(val) do i=1,s call suscr_insert_entry (a,val(i),indx(i),j,istat) if(istat.ne.0) return end do end subroutine suscr_insert_col ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine duscr_insert_col (a,j,val,indx,istat) implicit none real(KIND=dp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a,j integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx integer ::i,s istat=-1 s=size(val) do i=1,s call duscr_insert_entry (a,val(i),indx(i),j,istat) if(istat.ne.0) return end do end subroutine duscr_insert_col ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine cuscr_insert_col (a,j,val,indx,istat) implicit none complex(KIND=sp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a,j integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx integer ::i,s istat=-1 s=size(val) do i=1,s call cuscr_insert_entry (a,val(i),indx(i),j,istat) if(istat.ne.0) return end do end subroutine cuscr_insert_col ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine zuscr_insert_col (a,j,val,indx,istat) implicit none complex(KIND=dp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a,j integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx integer ::i,s istat=-1 s=size(val) do i=1,s call zuscr_insert_entry (a,val(i),indx(i),j,istat) if(istat.ne.0) return end do end subroutine zuscr_insert_col ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_col SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_entries.f90' then echo shar: will not over-write existing file "'uscr_insert_entries.f90'" else cat << "SHAR_EOF" > 'uscr_insert_entries.f90' module mod_uscr_insert_entries use blas_sparse_namedconstants use mod_uscr_insert_entry interface uscr_insert_entries module procedure iuscr_insert_entries module procedure suscr_insert_entries module procedure duscr_insert_entries module procedure cuscr_insert_entries module procedure zuscr_insert_entries end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine iuscr_insert_entries (a,val,indx,jndx,istat) implicit none integer ,dimension(:),intent(in) ::val integer ,intent(in) ::a integer,intent(out)::istat integer,dimension(:),intent(in)::indx,jndx integer ::i istat=-1 do i=1,size(val) call iuscr_insert_entry (a,val(i),indx(i),& jndx(i),istat) if(istat.ne.0) return end do end subroutine iuscr_insert_entries ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine suscr_insert_entries (a,val,indx,jndx,istat) implicit none real(KIND=sp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a integer,intent(out)::istat integer,dimension(:),intent(in)::indx,jndx integer ::i istat=-1 do i=1,size(val) call suscr_insert_entry (a,val(i),indx(i),& jndx(i),istat) if(istat.ne.0) return end do end subroutine suscr_insert_entries ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine duscr_insert_entries (a,val,indx,jndx,istat) implicit none real(KIND=dp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a integer,intent(out)::istat integer,dimension(:),intent(in)::indx,jndx integer ::i istat=-1 do i=1,size(val) call duscr_insert_entry (a,val(i),indx(i),& jndx(i),istat) if(istat.ne.0) return end do end subroutine duscr_insert_entries ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine cuscr_insert_entries (a,val,indx,jndx,istat) implicit none complex(KIND=sp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a integer,intent(out)::istat integer,dimension(:),intent(in)::indx,jndx integer ::i istat=-1 do i=1,size(val) call cuscr_insert_entry (a,val(i),indx(i),& jndx(i),istat) if(istat.ne.0) return end do end subroutine cuscr_insert_entries ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine zuscr_insert_entries (a,val,indx,jndx,istat) implicit none complex(KIND=dp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a integer,intent(out)::istat integer,dimension(:),intent(in)::indx,jndx integer ::i istat=-1 do i=1,size(val) call zuscr_insert_entry (a,val(i),indx(i),& jndx(i),istat) if(istat.ne.0) return end do end subroutine zuscr_insert_entries ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_entries SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_entry.f90' then echo shar: will not over-write existing file "'uscr_insert_entry.f90'" else cat << "SHAR_EOF" > 'uscr_insert_entry.f90' module mod_uscr_insert_entry use blas_sparse_namedconstants use mod_INSERTING use mod_INS_ROUTINER implicit none interface uscr_insert_entry module procedure iuscr_insert_entry module procedure suscr_insert_entry module procedure duscr_insert_entry module procedure cuscr_insert_entry module procedure zuscr_insert_entry end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine iuscr_insert_entry (a,val,i,j,istat) implicit none integer ,intent(in) ::val integer ,intent(in) ::a,i,j integer,intent(out)::istat type(i_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return select case(pmatrix%format) case('block') call iINS_bl_entr (pmatrix,val,i,j,istat) case('vblock') call iINS_varbl_entr (pmatrix,val,i,j,istat) case('normal') call iINS_entry (pmatrix,val,i,j,istat) case default istat = blas_error_param return end select end subroutine iuscr_insert_entry ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine suscr_insert_entry (a,val,i,j,istat) implicit none real(KIND=sp) ,intent(in) ::val integer ,intent(in) ::a,i,j integer,intent(out)::istat type(s_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return select case(pmatrix%format) case('block') call sINS_bl_entr (pmatrix,val,i,j,istat) case('vblock') call sINS_varbl_entr (pmatrix,val,i,j,istat) case('normal') call sINS_entry (pmatrix,val,i,j,istat) case default istat = blas_error_param return end select end subroutine suscr_insert_entry ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine duscr_insert_entry (a,val,i,j,istat) implicit none real(KIND=dp) ,intent(in) ::val integer ,intent(in) ::a,i,j integer,intent(out)::istat type(d_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return select case(pmatrix%format) case('block') call dINS_bl_entr (pmatrix,val,i,j,istat) case('vblock') call dINS_varbl_entr (pmatrix,val,i,j,istat) case('normal') call dINS_entry (pmatrix,val,i,j,istat) case default istat = blas_error_param return end select end subroutine duscr_insert_entry ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine cuscr_insert_entry (a,val,i,j,istat) implicit none complex(KIND=sp) ,intent(in) ::val integer ,intent(in) ::a,i,j integer,intent(out)::istat type(c_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return select case(pmatrix%format) case('block') call cINS_bl_entr (pmatrix,val,i,j,istat) case('vblock') call cINS_varbl_entr (pmatrix,val,i,j,istat) case('normal') call cINS_entry (pmatrix,val,i,j,istat) case default istat = blas_error_param return end select end subroutine cuscr_insert_entry ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine zuscr_insert_entry (a,val,i,j,istat) implicit none complex(KIND=dp) ,intent(in) ::val integer ,intent(in) ::a,i,j integer,intent(out)::istat type(z_matrix ),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return select case(pmatrix%format) case('block') call zINS_bl_entr (pmatrix,val,i,j,istat) case('vblock') call zINS_varbl_entr (pmatrix,val,i,j,istat) case('normal') call zINS_entry (pmatrix,val,i,j,istat) case default istat = blas_error_param return end select end subroutine zuscr_insert_entry ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_entry SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_row.f90' then echo shar: will not over-write existing file "'uscr_insert_row.f90'" else cat << "SHAR_EOF" > 'uscr_insert_row.f90' module mod_uscr_insert_row use blas_sparse_namedconstants use mod_uscr_insert_entry interface uscr_insert_row module procedure iuscr_insert_row module procedure suscr_insert_row module procedure duscr_insert_row module procedure cuscr_insert_row module procedure zuscr_insert_row end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine iuscr_insert_row (a,i,val,jndx,istat) implicit none integer ,dimension(:),intent(in) ::val integer ,intent(in) ::a,i integer,dimension(:),intent(in)::jndx integer ,intent(out)::istat integer ::k,s istat=-1 s=size(val) do k=1,s call iuscr_insert_entry (a,val(k),i,jndx(k),istat) if (istat.ne.0) return end do end subroutine iuscr_insert_row ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine suscr_insert_row (a,i,val,jndx,istat) implicit none real(KIND=sp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a,i integer,dimension(:),intent(in)::jndx integer ,intent(out)::istat integer ::k,s istat=-1 s=size(val) do k=1,s call suscr_insert_entry (a,val(k),i,jndx(k),istat) if (istat.ne.0) return end do end subroutine suscr_insert_row ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine duscr_insert_row (a,i,val,jndx,istat) implicit none real(KIND=dp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a,i integer,dimension(:),intent(in)::jndx integer ,intent(out)::istat integer ::k,s istat=-1 s=size(val) do k=1,s call duscr_insert_entry (a,val(k),i,jndx(k),istat) if (istat.ne.0) return end do end subroutine duscr_insert_row ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine cuscr_insert_row (a,i,val,jndx,istat) implicit none complex(KIND=sp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a,i integer,dimension(:),intent(in)::jndx integer ,intent(out)::istat integer ::k,s istat=-1 s=size(val) do k=1,s call cuscr_insert_entry (a,val(k),i,jndx(k),istat) if (istat.ne.0) return end do end subroutine cuscr_insert_row ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** subroutine zuscr_insert_row (a,i,val,jndx,istat) implicit none complex(KIND=dp) ,dimension(:),intent(in) ::val integer ,intent(in) ::a,i integer,dimension(:),intent(in)::jndx integer ,intent(out)::istat integer ::k,s istat=-1 s=size(val) do k=1,s call zuscr_insert_entry (a,val(k),i,jndx(k),istat) if (istat.ne.0) return end do end subroutine zuscr_insert_row ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_row SHAR_EOF fi # end of overwriting check if test -f 'uscr_variable_block_begin.f90' then echo shar: will not over-write existing file "'uscr_variable_block_begin.f90'" else cat << "SHAR_EOF" > 'uscr_variable_block_begin.f90' module mod_uscr_variable_block_begin use mod_INSERTING use properties implicit none contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_variable_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb integer,dimension(:),target,intent(in)::k,l integer ,intent(out)::a,istat integer ::nmb type(i_matrix ),pointer :: ipmatrix istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_i_matrix (nmb,Mb, istat) if (istat.ne.0) return call access_matrix(ipmatrix ,nmb, istat) if (istat.ne.0) return ipmatrix %DIM(3)=Mb !nb_of_block_rows ipmatrix %DIM(4)=Nb !nb_of_block_cols ipmatrix %sub_rows=>k ipmatrix %sub_cols=>l ipmatrix %trb=1 ipmatrix %tre=1 ipmatrix %format='vblock' a=nmb end if istat = 0 end subroutine iuscr_variable_block_begin ! ********************************************************************** ! ********************************************************************** subroutine suscr_variable_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb integer,dimension(:),target,intent(in)::k,l integer ,intent(out)::a,istat integer ::nmb type(s_matrix ),pointer :: spmatrix istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_s_matrix (nmb,Mb, istat) if (istat.ne.0) return call access_matrix(spmatrix ,nmb, istat) if (istat.ne.0) return spmatrix %DIM(3)=Mb !nb_of_block_rows spmatrix %DIM(4)=Nb !nb_of_block_cols spmatrix %sub_rows=>k spmatrix %sub_cols=>l spmatrix %trb=1 spmatrix %tre=1 spmatrix %format='vblock' a=nmb end if istat = 0 end subroutine suscr_variable_block_begin ! ********************************************************************** ! ********************************************************************** subroutine duscr_variable_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb integer,dimension(:),target,intent(in)::k,l integer ,intent(out)::a,istat integer ::nmb type(d_matrix ),pointer :: dpmatrix istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_d_matrix (nmb,Mb, istat) if (istat.ne.0) return call access_matrix(dpmatrix ,nmb, istat) if (istat.ne.0) return dpmatrix %DIM(3)=Mb !nb_of_block_rows dpmatrix %DIM(4)=Nb !nb_of_block_cols dpmatrix %sub_rows=>k dpmatrix %sub_cols=>l dpmatrix %trb=1 dpmatrix %tre=1 dpmatrix %format='vblock' a=nmb end if istat = 0 end subroutine duscr_variable_block_begin ! ********************************************************************** ! ********************************************************************** subroutine cuscr_variable_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb integer,dimension(:),target,intent(in)::k,l integer ,intent(out)::a,istat integer ::nmb type(c_matrix ),pointer :: cpmatrix istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_c_matrix (nmb,Mb, istat) if (istat.ne.0) return call access_matrix(cpmatrix ,nmb, istat) if (istat.ne.0) return cpmatrix %DIM(3)=Mb !nb_of_block_rows cpmatrix %DIM(4)=Nb !nb_of_block_cols cpmatrix %sub_rows=>k cpmatrix %sub_cols=>l cpmatrix %trb=1 cpmatrix %tre=1 cpmatrix %format='vblock' a=nmb end if istat = 0 end subroutine cuscr_variable_block_begin ! ********************************************************************** ! ********************************************************************** subroutine zuscr_variable_block_begin (Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb integer,dimension(:),target,intent(in)::k,l integer ,intent(out)::a,istat integer ::nmb type(z_matrix ),pointer :: zpmatrix istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call new_z_matrix (nmb,Mb, istat) if (istat.ne.0) return call access_matrix(zpmatrix ,nmb, istat) if (istat.ne.0) return zpmatrix %DIM(3)=Mb !nb_of_block_rows zpmatrix %DIM(4)=Nb !nb_of_block_cols zpmatrix %sub_rows=>k zpmatrix %sub_cols=>l zpmatrix %trb=1 zpmatrix %tre=1 zpmatrix %format='vblock' a=nmb end if istat = 0 end subroutine zuscr_variable_block_begin ! ********************************************************************** ! ********************************************************************** end module mod_uscr_variable_block_begin SHAR_EOF fi # end of overwriting check if test -f 'uscr_vbr.f90' then echo shar: will not over-write existing file "'uscr_vbr.f90'" else cat << "SHAR_EOF" > 'uscr_vbr.f90' module mod_uscr_vbr ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'VBR'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_vbr module procedure iuscr_vbr module procedure suscr_vbr module procedure duscr_vbr module procedure cuscr_vbr module procedure zuscr_vbr end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iuscr_vbr (m,n,val,indx,bindx,rpntr,cpntr,bpntrb,& bpntre,mb,kb,prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,prpty integer, dimension(:), intent(inout),target :: indx,bindx,& rpntr,cpntr,bpntrb,bpntre integer , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(ispmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'VBR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',-1,ierr) !row-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'e',-1,ierr) !col-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(mb.ne.size(bpntre)).or.& (size(val).ne.maxval(indx)-base).or.(minval(indx).lt.base).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => indx dsp_data%pb => bpntrb dsp_data%pe => bpntre dsp_data%bp1 => rpntr dsp_data%bp2 => cpntr istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(indx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre)),& dsp_data%bp1(size(rpntr)),dsp_data%bp2(size(cpntr)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = indx dsp_data%pb = bpntrb dsp_data%pe = bpntre dsp_data%bp1 = rpntr dsp_data%bp2 = cpntr istat = 1 end if if(istat.ge.0) a = nmb end subroutine iuscr_vbr ! ********************************************************************** ! ********************************************************************** subroutine suscr_vbr (m,n,val,indx,bindx,rpntr,cpntr,bpntrb,& bpntre,mb,kb,prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,prpty integer, dimension(:), intent(inout),target :: indx,bindx,& rpntr,cpntr,bpntrb,bpntre real(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(sspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'VBR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',-1,ierr) !row-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'e',-1,ierr) !col-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(mb.ne.size(bpntre)).or.& (size(val).ne.maxval(indx)-base).or.(minval(indx).lt.base).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => indx dsp_data%pb => bpntrb dsp_data%pe => bpntre dsp_data%bp1 => rpntr dsp_data%bp2 => cpntr istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(indx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre)),& dsp_data%bp1(size(rpntr)),dsp_data%bp2(size(cpntr)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = indx dsp_data%pb = bpntrb dsp_data%pe = bpntre dsp_data%bp1 = rpntr dsp_data%bp2 = cpntr istat = 1 end if if(istat.ge.0) a = nmb end subroutine suscr_vbr ! ********************************************************************** ! ********************************************************************** subroutine duscr_vbr (m,n,val,indx,bindx,rpntr,cpntr,bpntrb,& bpntre,mb,kb,prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,prpty integer, dimension(:), intent(inout),target :: indx,bindx,& rpntr,cpntr,bpntrb,bpntre real(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(dspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'VBR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',-1,ierr) !row-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'e',-1,ierr) !col-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(mb.ne.size(bpntre)).or.& (size(val).ne.maxval(indx)-base).or.(minval(indx).lt.base).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => indx dsp_data%pb => bpntrb dsp_data%pe => bpntre dsp_data%bp1 => rpntr dsp_data%bp2 => cpntr istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(indx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre)),& dsp_data%bp1(size(rpntr)),dsp_data%bp2(size(cpntr)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = indx dsp_data%pb = bpntrb dsp_data%pe = bpntre dsp_data%bp1 = rpntr dsp_data%bp2 = cpntr istat = 1 end if if(istat.ge.0) a = nmb end subroutine duscr_vbr ! ********************************************************************** ! ********************************************************************** subroutine cuscr_vbr (m,n,val,indx,bindx,rpntr,cpntr,bpntrb,& bpntre,mb,kb,prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,prpty integer, dimension(:), intent(inout),target :: indx,bindx,& rpntr,cpntr,bpntrb,bpntre complex(KIND=sp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(cspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'VBR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',-1,ierr) !row-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'e',-1,ierr) !col-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(mb.ne.size(bpntre)).or.& (size(val).ne.maxval(indx)-base).or.(minval(indx).lt.base).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => indx dsp_data%pb => bpntrb dsp_data%pe => bpntre dsp_data%bp1 => rpntr dsp_data%bp2 => cpntr istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(indx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre)),& dsp_data%bp1(size(rpntr)),dsp_data%bp2(size(cpntr)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = indx dsp_data%pb = bpntrb dsp_data%pe = bpntre dsp_data%bp1 = rpntr dsp_data%bp2 = cpntr istat = 1 end if if(istat.ge.0) a = nmb end subroutine cuscr_vbr ! ********************************************************************** ! ********************************************************************** subroutine zuscr_vbr (m,n,val,indx,bindx,rpntr,cpntr,bpntrb,& bpntre,mb,kb,prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,prpty integer, dimension(:), intent(inout),target :: indx,bindx,& rpntr,cpntr,bpntrb,bpntre complex(KIND=dp) , dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(zspmat ),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call new_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'VBR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',-1,ierr) !row-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'e',-1,ierr) !col-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(mb.ne.size(bpntre)).or.& (size(val).ne.maxval(indx)-base).or.(minval(indx).lt.base).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => indx dsp_data%pb => bpntrb dsp_data%pe => bpntre dsp_data%bp1 => rpntr dsp_data%bp2 => cpntr istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(indx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre)),& dsp_data%bp1(size(rpntr)),dsp_data%bp2(size(cpntr)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = indx dsp_data%pb = bpntrb dsp_data%pe = bpntre dsp_data%bp1 = rpntr dsp_data%bp2 = cpntr istat = 1 end if if(istat.ge.0) a = nmb end subroutine zuscr_vbr ! ********************************************************************** ! ********************************************************************** end module mod_uscr_vbr SHAR_EOF fi # end of overwriting check if test -f 'usdot.f90' then echo shar: will not over-write existing file "'usdot.f90'" else cat << "SHAR_EOF" > 'usdot.f90' module mod_usdot use blas_sparse_namedconstants interface usdot module procedure iusdot module procedure susdot module procedure dusdot module procedure cusdot module procedure zusdot end interface contains ! ********************************************************************** ! ********************************************************************** integer function iusdot (x,indx,y,conj) implicit none integer,dimension(:),intent(in) :: indx integer ,dimension(:),intent(in) ::x,y integer ,dimension(:),allocatable :: zy integer,optional ::conj integer ::t intrinsic dot_product,conjg,cmplx t=size(indx) if(t.le.0) then iusdot =0. else allocate(zy(t)) zy= y(indx) if(present(conj)) then iusdot =dot_product(x,zy) else iusdot =dot_product(conjg(cmplx(x)),zy) end if deallocate(zy) end if end function iusdot ! ********************************************************************** ! ********************************************************************** real(KIND=sp) function susdot (x,indx,y,conj) implicit none integer,dimension(:),intent(in) :: indx real(KIND=sp) ,dimension(:),intent(in) ::x,y real(KIND=sp) ,dimension(:),allocatable :: zy integer,optional ::conj integer ::t intrinsic dot_product,conjg,cmplx t=size(indx) if(t.le.0) then susdot =0. else allocate(zy(t)) zy= y(indx) if(present(conj)) then susdot =dot_product(x,zy) else susdot =dot_product(conjg(cmplx(x)),zy) end if deallocate(zy) end if end function susdot ! ********************************************************************** ! ********************************************************************** real(KIND=dp) function dusdot (x,indx,y,conj) implicit none integer,dimension(:),intent(in) :: indx real(KIND=dp) ,dimension(:),intent(in) ::x,y real(KIND=dp) ,dimension(:),allocatable :: zy integer,optional ::conj integer ::t intrinsic dot_product,conjg,cmplx t=size(indx) if(t.le.0) then dusdot =0. else allocate(zy(t)) zy= y(indx) if(present(conj)) then dusdot =dot_product(x,zy) else dusdot =dot_product(conjg(cmplx(x)),zy) end if deallocate(zy) end if end function dusdot ! ********************************************************************** ! ********************************************************************** complex(KIND=sp) function cusdot (x,indx,y,conj) implicit none integer,dimension(:),intent(in) :: indx complex(KIND=sp) ,dimension(:),intent(in) ::x,y complex(KIND=sp) ,dimension(:),allocatable :: zy integer,optional ::conj integer ::t intrinsic dot_product,conjg,cmplx t=size(indx) if(t.le.0) then cusdot =0. else allocate(zy(t)) zy= y(indx) if(present(conj)) then cusdot =dot_product(x,zy) else cusdot =dot_product(conjg(cmplx(x)),zy) end if deallocate(zy) end if end function cusdot ! ********************************************************************** ! ********************************************************************** complex(KIND=dp) function zusdot (x,indx,y,conj) implicit none integer,dimension(:),intent(in) :: indx complex(KIND=dp) ,dimension(:),intent(in) ::x,y complex(KIND=dp) ,dimension(:),allocatable :: zy integer,optional ::conj integer ::t intrinsic dot_product,conjg,cmplx t=size(indx) if(t.le.0) then zusdot =0. else allocate(zy(t)) zy= y(indx) if(present(conj)) then zusdot =dot_product(x,zy) else zusdot =dot_product(conjg(cmplx(x)),zy) end if deallocate(zy) end if end function zusdot ! ********************************************************************** ! ********************************************************************** end module mod_usdot SHAR_EOF fi # end of overwriting check if test -f 'usds.f90' then echo shar: will not over-write existing file "'usds.f90'" else cat << "SHAR_EOF" > 'usds.f90' module mod_usds ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : RELEASES HANDLES, LOOKS FOR THE "FREEDOM OF MEMORY" ! ********************************************************************** use representation_of_data use properties implicit none contains subroutine usds(nmb,ierr) implicit none intrinsic modulo integer, intent(in) :: nmb integer, intent(out) :: ierr type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer :: rest,val rest = modulo(nmb,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call accessdata(isp_data ,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(isp_data %INFOA,'c',val,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(val.eq.COP_OF_SOURCE) then ! *** Deallocate extra storage for copy of matrix *** ! select case(isp_data %FIDA) case('COO','BCO') deallocate(isp_data %A,isp_data %IA1,isp_data %IA2,STAT=ierr) case('CSC','BSC') deallocate(isp_data %A,isp_data %IA1,isp_data %pb,isp_data %pe,& STAT=ierr) case('CSR','BSR') deallocate(isp_data %A,isp_data %IA1,isp_data %pb,isp_data %pe,& STAT=ierr) case('DIA','BDI') deallocate(isp_data %A,isp_data %IA1,STAT=ierr) case('VBR') deallocate(isp_data %A,isp_data %IA1,isp_data %IA2,& isp_data %PB,isp_data %PE,isp_data %BP1,isp_data %BP2& ,STAT=ierr) case default ierr = blas_error_param return end select if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call del_isp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** call accessdata(ssp_data ,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(ssp_data %INFOA,'c',val,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(val.eq.COP_OF_SOURCE) then ! *** Deallocate extra storage for copy of matrix *** ! select case(ssp_data %FIDA) case('COO','BCO') deallocate(ssp_data %A,ssp_data %IA1,ssp_data %IA2,STAT=ierr) case('CSC','BSC') deallocate(ssp_data %A,ssp_data %IA1,ssp_data %pb,ssp_data %pe,& STAT=ierr) case('CSR','BSR') deallocate(ssp_data %A,ssp_data %IA1,ssp_data %pb,ssp_data %pe,& STAT=ierr) case('DIA','BDI') deallocate(ssp_data %A,ssp_data %IA1,STAT=ierr) case('VBR') deallocate(ssp_data %A,ssp_data %IA1,ssp_data %IA2,& ssp_data %PB,ssp_data %PE,ssp_data %BP1,ssp_data %BP2& ,STAT=ierr) case default ierr = blas_error_param return end select if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call del_ssp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** call accessdata(dsp_data ,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(dsp_data %INFOA,'c',val,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(val.eq.COP_OF_SOURCE) then ! *** Deallocate extra storage for copy of matrix *** ! select case(dsp_data %FIDA) case('COO','BCO') deallocate(dsp_data %A,dsp_data %IA1,dsp_data %IA2,STAT=ierr) case('CSC','BSC') deallocate(dsp_data %A,dsp_data %IA1,dsp_data %pb,dsp_data %pe,& STAT=ierr) case('CSR','BSR') deallocate(dsp_data %A,dsp_data %IA1,dsp_data %pb,dsp_data %pe,& STAT=ierr) case('DIA','BDI') deallocate(dsp_data %A,dsp_data %IA1,STAT=ierr) case('VBR') deallocate(dsp_data %A,dsp_data %IA1,dsp_data %IA2,& dsp_data %PB,dsp_data %PE,dsp_data %BP1,dsp_data %BP2& ,STAT=ierr) case default ierr = blas_error_param return end select if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call del_dsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** call accessdata(csp_data ,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(csp_data %INFOA,'c',val,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(val.eq.COP_OF_SOURCE) then ! *** Deallocate extra storage for copy of matrix *** ! select case(csp_data %FIDA) case('COO','BCO') deallocate(csp_data %A,csp_data %IA1,csp_data %IA2,STAT=ierr) case('CSC','BSC') deallocate(csp_data %A,csp_data %IA1,csp_data %pb,csp_data %pe,& STAT=ierr) case('CSR','BSR') deallocate(csp_data %A,csp_data %IA1,csp_data %pb,csp_data %pe,& STAT=ierr) case('DIA','BDI') deallocate(csp_data %A,csp_data %IA1,STAT=ierr) case('VBR') deallocate(csp_data %A,csp_data %IA1,csp_data %IA2,& csp_data %PB,csp_data %PE,csp_data %BP1,csp_data %BP2& ,STAT=ierr) case default ierr = blas_error_param return end select if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call del_csp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call accessdata(zsp_data ,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(zsp_data %INFOA,'c',val,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(val.eq.COP_OF_SOURCE) then ! *** Deallocate extra storage for copy of matrix *** ! select case(zsp_data %FIDA) case('COO','BCO') deallocate(zsp_data %A,zsp_data %IA1,zsp_data %IA2,STAT=ierr) case('CSC','BSC') deallocate(zsp_data %A,zsp_data %IA1,zsp_data %pb,zsp_data %pe,& STAT=ierr) case('CSR','BSR') deallocate(zsp_data %A,zsp_data %IA1,zsp_data %pb,zsp_data %pe,& STAT=ierr) case('DIA','BDI') deallocate(zsp_data %A,zsp_data %IA1,STAT=ierr) case('VBR') deallocate(zsp_data %A,zsp_data %IA1,zsp_data %IA2,& zsp_data %PB,zsp_data %PE,zsp_data %BP1,zsp_data %BP2& ,STAT=ierr) case default ierr = blas_error_param return end select if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call del_zsp (nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if ! ********************************************************************** case default ierr = blas_error_param end select if (ierr.ne.0) then ierr = blas_error_param return end if end subroutine usds end module mod_usds SHAR_EOF fi # end of overwriting check if test -f 'usga.f90' then echo shar: will not over-write existing file "'usga.f90'" else cat << "SHAR_EOF" > 'usga.f90' module mod_usga use blas_sparse_namedconstants interface usga module procedure iusga module procedure susga module procedure dusga module procedure cusga module procedure zusga end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iusga (y,x,indx) integer ,dimension(:),intent(inout) ::x integer ,dimension(:),intent(in) ::y integer,dimension(:),intent(in)::indx integer ::t,i t=size(x) if(t.gt.0) then do i=1,t x(i)=y(indx(i)) end do end if end subroutine iusga ! ********************************************************************** ! ********************************************************************** subroutine susga (y,x,indx) real(KIND=sp) ,dimension(:),intent(inout) ::x real(KIND=sp) ,dimension(:),intent(in) ::y integer,dimension(:),intent(in)::indx integer ::t,i t=size(x) if(t.gt.0) then do i=1,t x(i)=y(indx(i)) end do end if end subroutine susga ! ********************************************************************** ! ********************************************************************** subroutine dusga (y,x,indx) real(KIND=dp) ,dimension(:),intent(inout) ::x real(KIND=dp) ,dimension(:),intent(in) ::y integer,dimension(:),intent(in)::indx integer ::t,i t=size(x) if(t.gt.0) then do i=1,t x(i)=y(indx(i)) end do end if end subroutine dusga ! ********************************************************************** ! ********************************************************************** subroutine cusga (y,x,indx) complex(KIND=sp) ,dimension(:),intent(inout) ::x complex(KIND=sp) ,dimension(:),intent(in) ::y integer,dimension(:),intent(in)::indx integer ::t,i t=size(x) if(t.gt.0) then do i=1,t x(i)=y(indx(i)) end do end if end subroutine cusga ! ********************************************************************** ! ********************************************************************** subroutine zusga (y,x,indx) complex(KIND=dp) ,dimension(:),intent(inout) ::x complex(KIND=dp) ,dimension(:),intent(in) ::y integer,dimension(:),intent(in)::indx integer ::t,i t=size(x) if(t.gt.0) then do i=1,t x(i)=y(indx(i)) end do end if end subroutine zusga ! ********************************************************************** ! ********************************************************************** end module mod_usga SHAR_EOF fi # end of overwriting check if test -f 'usgp.f90' then echo shar: will not over-write existing file "'usgp.f90'" else cat << "SHAR_EOF" > 'usgp.f90' module mod_usgp use mod_INSERTING use properties use representation_of_data contains subroutine usgp (a,pname,m) implicit none integer ,intent(in)::a integer,intent(out)::m integer,intent(in)::pname type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data type(i_matrix),pointer :: imatrix type(s_matrix),pointer :: smatrix type(d_matrix),pointer :: dmatrix type(c_matrix),pointer :: cmatrix type(z_matrix),pointer :: zmatrix integer ::rest,ierr character ::test rest = modulo(a,no_of_types) select case(rest) ! ********************************************************************** ! ********************************************************************** case(ISP_MATRIX) m=0 ierr=-1 if (a.ge.0) then call accessdata(isp_data ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_valid_handle) then m=1 end if else call iaccess_matrix (imatrix ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_new_handle) then if (imatrix %new.eq.1) then m=1 else m=0 end if elseif(pname.eq.blas_open_handle) then if (imatrix %new.eq.0) then m=1 else m=0 end if else m=-1 return end if end if if(pname.eq.blas_zero_base) then call get_descra(isp_data %DESCRA,'b',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_one_base) then call get_descra(isp_data %DESCRA,'b',test,ierr) if(test.eq.'F') then m=1 end if elseif(pname.eq.blas_general) then call get_descra(isp_data %DESCRA,'t',test,ierr) if(test.eq.'G') then m=1 end if elseif(pname.eq.blas_symmetric) then call get_descra(isp_data %DESCRA,'t',test,ierr) if(test.eq.'S') then m=1 end if elseif(pname.eq.blas_hermitian) then call get_descra(isp_data %DESCRA,'t',test,ierr) if(test.eq.'H') then m=1 end if elseif(pname.eq.blas_upper_triangular) then call get_descra(isp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(isp_data %DESCRA,'a',test,ierr) if(test.eq.'U') then m=1 end if end if elseif(pname.eq.blas_lower_triangular) then call get_descra(isp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(isp_data %DESCRA,'a',test,ierr) if(test.eq.'L') then m=1 end if end if elseif(pname.eq.blas_row_major) then call get_descra(isp_data %DESCRA,'f',test,ierr) if(test.eq.'R') then m=1 end if elseif(pname.eq.blas_col_major) then call get_descra(isp_data %DESCRA,'f',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_complex) then if ((rest.eq.CSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_real) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.DSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_integer) then if (rest.eq.ISP_MATRIX) then m=1 else m=0 end if elseif(pname.eq.blas_double_precision) then if ((rest.eq.DSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_single_precision) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.CSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_num_rows) then m= isp_data %M elseif(pname.eq.blas_num_cols) then m= isp_data %K elseif(pname.eq.blas_num_nonzeros) then call get_infoa(isp_data %INFOA,'n',m,ierr) else m=-1 return end if ! ********************************************************************** ! ********************************************************************** case(SSP_MATRIX) m=0 ierr=-1 if (a.ge.0) then call accessdata(ssp_data ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_valid_handle) then m=1 end if else call saccess_matrix (smatrix ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_new_handle) then if (smatrix %new.eq.1) then m=1 else m=0 end if elseif(pname.eq.blas_open_handle) then if (smatrix %new.eq.0) then m=1 else m=0 end if else m=-1 return end if end if if(pname.eq.blas_zero_base) then call get_descra(ssp_data %DESCRA,'b',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_one_base) then call get_descra(ssp_data %DESCRA,'b',test,ierr) if(test.eq.'F') then m=1 end if elseif(pname.eq.blas_general) then call get_descra(ssp_data %DESCRA,'t',test,ierr) if(test.eq.'G') then m=1 end if elseif(pname.eq.blas_symmetric) then call get_descra(ssp_data %DESCRA,'t',test,ierr) if(test.eq.'S') then m=1 end if elseif(pname.eq.blas_hermitian) then call get_descra(ssp_data %DESCRA,'t',test,ierr) if(test.eq.'H') then m=1 end if elseif(pname.eq.blas_upper_triangular) then call get_descra(ssp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(ssp_data %DESCRA,'a',test,ierr) if(test.eq.'U') then m=1 end if end if elseif(pname.eq.blas_lower_triangular) then call get_descra(ssp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(ssp_data %DESCRA,'a',test,ierr) if(test.eq.'L') then m=1 end if end if elseif(pname.eq.blas_row_major) then call get_descra(ssp_data %DESCRA,'f',test,ierr) if(test.eq.'R') then m=1 end if elseif(pname.eq.blas_col_major) then call get_descra(ssp_data %DESCRA,'f',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_complex) then if ((rest.eq.CSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_real) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.DSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_integer) then if (rest.eq.ISP_MATRIX) then m=1 else m=0 end if elseif(pname.eq.blas_double_precision) then if ((rest.eq.DSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_single_precision) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.CSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_num_rows) then m= ssp_data %M elseif(pname.eq.blas_num_cols) then m= ssp_data %K elseif(pname.eq.blas_num_nonzeros) then call get_infoa(ssp_data %INFOA,'n',m,ierr) else m=-1 return end if ! ********************************************************************** ! ********************************************************************** case(DSP_MATRIX) m=0 ierr=-1 if (a.ge.0) then call accessdata(dsp_data ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_valid_handle) then m=1 end if else call daccess_matrix (dmatrix ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_new_handle) then if (dmatrix %new.eq.1) then m=1 else m=0 end if elseif(pname.eq.blas_open_handle) then if (dmatrix %new.eq.0) then m=1 else m=0 end if else m=-1 return end if end if if(pname.eq.blas_zero_base) then call get_descra(dsp_data %DESCRA,'b',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_one_base) then call get_descra(dsp_data %DESCRA,'b',test,ierr) if(test.eq.'F') then m=1 end if elseif(pname.eq.blas_general) then call get_descra(dsp_data %DESCRA,'t',test,ierr) if(test.eq.'G') then m=1 end if elseif(pname.eq.blas_symmetric) then call get_descra(dsp_data %DESCRA,'t',test,ierr) if(test.eq.'S') then m=1 end if elseif(pname.eq.blas_hermitian) then call get_descra(dsp_data %DESCRA,'t',test,ierr) if(test.eq.'H') then m=1 end if elseif(pname.eq.blas_upper_triangular) then call get_descra(dsp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(dsp_data %DESCRA,'a',test,ierr) if(test.eq.'U') then m=1 end if end if elseif(pname.eq.blas_lower_triangular) then call get_descra(dsp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(dsp_data %DESCRA,'a',test,ierr) if(test.eq.'L') then m=1 end if end if elseif(pname.eq.blas_row_major) then call get_descra(dsp_data %DESCRA,'f',test,ierr) if(test.eq.'R') then m=1 end if elseif(pname.eq.blas_col_major) then call get_descra(dsp_data %DESCRA,'f',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_complex) then if ((rest.eq.CSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_real) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.DSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_integer) then if (rest.eq.ISP_MATRIX) then m=1 else m=0 end if elseif(pname.eq.blas_double_precision) then if ((rest.eq.DSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_single_precision) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.CSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_num_rows) then m= dsp_data %M elseif(pname.eq.blas_num_cols) then m= dsp_data %K elseif(pname.eq.blas_num_nonzeros) then call get_infoa(dsp_data %INFOA,'n',m,ierr) else m=-1 return end if ! ********************************************************************** ! ********************************************************************** case(CSP_MATRIX) m=0 ierr=-1 if (a.ge.0) then call accessdata(csp_data ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_valid_handle) then m=1 end if else call caccess_matrix (cmatrix ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_new_handle) then if (cmatrix %new.eq.1) then m=1 else m=0 end if elseif(pname.eq.blas_open_handle) then if (cmatrix %new.eq.0) then m=1 else m=0 end if else m=-1 return end if end if if(pname.eq.blas_zero_base) then call get_descra(csp_data %DESCRA,'b',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_one_base) then call get_descra(csp_data %DESCRA,'b',test,ierr) if(test.eq.'F') then m=1 end if elseif(pname.eq.blas_general) then call get_descra(csp_data %DESCRA,'t',test,ierr) if(test.eq.'G') then m=1 end if elseif(pname.eq.blas_symmetric) then call get_descra(csp_data %DESCRA,'t',test,ierr) if(test.eq.'S') then m=1 end if elseif(pname.eq.blas_hermitian) then call get_descra(csp_data %DESCRA,'t',test,ierr) if(test.eq.'H') then m=1 end if elseif(pname.eq.blas_upper_triangular) then call get_descra(csp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(csp_data %DESCRA,'a',test,ierr) if(test.eq.'U') then m=1 end if end if elseif(pname.eq.blas_lower_triangular) then call get_descra(csp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(csp_data %DESCRA,'a',test,ierr) if(test.eq.'L') then m=1 end if end if elseif(pname.eq.blas_row_major) then call get_descra(csp_data %DESCRA,'f',test,ierr) if(test.eq.'R') then m=1 end if elseif(pname.eq.blas_col_major) then call get_descra(csp_data %DESCRA,'f',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_complex) then if ((rest.eq.CSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_real) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.DSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_integer) then if (rest.eq.ISP_MATRIX) then m=1 else m=0 end if elseif(pname.eq.blas_double_precision) then if ((rest.eq.DSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_single_precision) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.CSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_num_rows) then m= csp_data %M elseif(pname.eq.blas_num_cols) then m= csp_data %K elseif(pname.eq.blas_num_nonzeros) then call get_infoa(csp_data %INFOA,'n',m,ierr) else m=-1 return end if ! ********************************************************************** ! ********************************************************************** case(ZSP_MATRIX) m=0 ierr=-1 if (a.ge.0) then call accessdata(zsp_data ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_valid_handle) then m=1 end if else call zaccess_matrix (zmatrix ,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_new_handle) then if (zmatrix %new.eq.1) then m=1 else m=0 end if elseif(pname.eq.blas_open_handle) then if (zmatrix %new.eq.0) then m=1 else m=0 end if else m=-1 return end if end if if(pname.eq.blas_zero_base) then call get_descra(zsp_data %DESCRA,'b',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_one_base) then call get_descra(zsp_data %DESCRA,'b',test,ierr) if(test.eq.'F') then m=1 end if elseif(pname.eq.blas_general) then call get_descra(zsp_data %DESCRA,'t',test,ierr) if(test.eq.'G') then m=1 end if elseif(pname.eq.blas_symmetric) then call get_descra(zsp_data %DESCRA,'t',test,ierr) if(test.eq.'S') then m=1 end if elseif(pname.eq.blas_hermitian) then call get_descra(zsp_data %DESCRA,'t',test,ierr) if(test.eq.'H') then m=1 end if elseif(pname.eq.blas_upper_triangular) then call get_descra(zsp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(zsp_data %DESCRA,'a',test,ierr) if(test.eq.'U') then m=1 end if end if elseif(pname.eq.blas_lower_triangular) then call get_descra(zsp_data %DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(zsp_data %DESCRA,'a',test,ierr) if(test.eq.'L') then m=1 end if end if elseif(pname.eq.blas_row_major) then call get_descra(zsp_data %DESCRA,'f',test,ierr) if(test.eq.'R') then m=1 end if elseif(pname.eq.blas_col_major) then call get_descra(zsp_data %DESCRA,'f',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_complex) then if ((rest.eq.CSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_real) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.DSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_integer) then if (rest.eq.ISP_MATRIX) then m=1 else m=0 end if elseif(pname.eq.blas_double_precision) then if ((rest.eq.DSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_single_precision) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.CSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_num_rows) then m= zsp_data %M elseif(pname.eq.blas_num_cols) then m= zsp_data %K elseif(pname.eq.blas_num_nonzeros) then call get_infoa(zsp_data %INFOA,'n',m,ierr) else m=-1 return end if ! ********************************************************************** ! ********************************************************************** case default return end select end subroutine usgp end module mod_usgp SHAR_EOF fi # end of overwriting check if test -f 'usgz.f90' then echo shar: will not over-write existing file "'usgz.f90'" else cat << "SHAR_EOF" > 'usgz.f90' module mod_usgz use mod_usga use blas_sparse_namedconstants interface usgz module procedure iusgz module procedure susgz module procedure dusgz module procedure cusgz module procedure zusgz end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iusgz (y,x,indx) integer ,dimension(:),intent(out) ::x integer ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer ::i,t t=size(indx) if(t.gt.0) then call usga(y,x,indx) do i=1,t y(indx(i))=0 end do end if end subroutine iusgz ! ********************************************************************** ! ********************************************************************** subroutine susgz (y,x,indx) real(KIND=sp) ,dimension(:),intent(out) ::x real(KIND=sp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer ::i,t t=size(indx) if(t.gt.0) then call usga(y,x,indx) do i=1,t y(indx(i))=0 end do end if end subroutine susgz ! ********************************************************************** ! ********************************************************************** subroutine dusgz (y,x,indx) real(KIND=dp) ,dimension(:),intent(out) ::x real(KIND=dp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer ::i,t t=size(indx) if(t.gt.0) then call usga(y,x,indx) do i=1,t y(indx(i))=0 end do end if end subroutine dusgz ! ********************************************************************** ! ********************************************************************** subroutine cusgz (y,x,indx) complex(KIND=sp) ,dimension(:),intent(out) ::x complex(KIND=sp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer ::i,t t=size(indx) if(t.gt.0) then call usga(y,x,indx) do i=1,t y(indx(i))=0 end do end if end subroutine cusgz ! ********************************************************************** ! ********************************************************************** subroutine zusgz (y,x,indx) complex(KIND=dp) ,dimension(:),intent(out) ::x complex(KIND=dp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer ::i,t t=size(indx) if(t.gt.0) then call usga(y,x,indx) do i=1,t y(indx(i))=0 end do end if end subroutine zusgz ! ********************************************************************** ! ********************************************************************** end module mod_usgz SHAR_EOF fi # end of overwriting check if test -f 'usmm.f90' then echo shar: will not over-write existing file "'usmm.f90'" else cat << "SHAR_EOF" > 'usmm.f90' module mod_usmm ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : MM MULTIPLICATION, CHOOSES APPROPRIATE SUBROUTINES ! ********************************************************************** use representation_of_data use properties use mod_mbv implicit none interface usmm module procedure iusmm module procedure susmm module procedure dusmm module procedure cusmm module procedure zusmm end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iusmm (a,b,c,ierr,transa,alpha) implicit none integer, intent(in) :: a integer , dimension(:,:), intent(in) :: b integer , dimension(:,:), intent(inout) :: c integer, intent(out) :: ierr integer, intent(in), optional :: transa integer , intent(in), optional :: alpha integer , dimension(:), allocatable :: z type(ispmat ), pointer :: dspmtx integer transa_work,i integer :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. 0 ) then !no matrix multiplication necessary else call accessdata_isp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(c,1)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,b(:,i),z,ierr) case('CSC') call rmbv_csc(dspmtx,b(:,i),z,ierr) case('CSR') call rmbv_csr(dspmtx,b(:,i),z,ierr) case('DIA') call rmbv_dia(dspmtx,b(:,i),z,ierr) case('BCO') call rmbv_bco(dspmtx,b(:,i),z,ierr) case('BSC') call rmbv_bsc(dspmtx,b(:,i),z,ierr) case('BSR') call rmbv_bsr(dspmtx,b(:,i),z,ierr) case('BDI') call rmbv_bdi(dspmtx,b(:,i),z,ierr) case('VBR') call rmbv_vbr(dspmtx,b(:,i),z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx, (b(:,i)),z,ierr) case('CSC') call lmbv_csc(dspmtx, (b(:,i)),z,ierr) case('CSR') call lmbv_csr(dspmtx, (b(:,i)),z,ierr) case('DIA') call lmbv_dia(dspmtx, (b(:,i)),z,ierr) case('BCO') call lmbv_bco(dspmtx, (b(:,i)),z,ierr) case('BSC') call lmbv_bsc(dspmtx, (b(:,i)),z,ierr) case('BSR') call lmbv_bsr(dspmtx, (b(:,i)),z,ierr) case('BDI') call lmbv_bdi(dspmtx, (b(:,i)),z,ierr) case('VBR') call lmbv_vbr(dspmtx, (b(:,i)),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return else if(transa_work.eq.ORIGIN_MATRIX) then c(:,i) = alpha_work * z + c(:,i) else c(:,i) = alpha_work * ( (z)) + c(:,i) end if end if end do deallocate(z,STAT=ierr) end if ierr = 0 end subroutine iusmm ! ********************************************************************** ! ********************************************************************** subroutine susmm (a,b,c,ierr,transa,alpha) implicit none integer, intent(in) :: a real(KIND=sp) , dimension(:,:), intent(in) :: b real(KIND=sp) , dimension(:,:), intent(inout) :: c integer, intent(out) :: ierr integer, intent(in), optional :: transa real(KIND=sp) , intent(in), optional :: alpha real(KIND=sp) , dimension(:), allocatable :: z type(sspmat ), pointer :: dspmtx integer transa_work,i real(KIND=sp) :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. 0.0e0 ) then !no matrix multiplication necessary else call accessdata_ssp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(c,1)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,b(:,i),z,ierr) case('CSC') call rmbv_csc(dspmtx,b(:,i),z,ierr) case('CSR') call rmbv_csr(dspmtx,b(:,i),z,ierr) case('DIA') call rmbv_dia(dspmtx,b(:,i),z,ierr) case('BCO') call rmbv_bco(dspmtx,b(:,i),z,ierr) case('BSC') call rmbv_bsc(dspmtx,b(:,i),z,ierr) case('BSR') call rmbv_bsr(dspmtx,b(:,i),z,ierr) case('BDI') call rmbv_bdi(dspmtx,b(:,i),z,ierr) case('VBR') call rmbv_vbr(dspmtx,b(:,i),z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx, (b(:,i)),z,ierr) case('CSC') call lmbv_csc(dspmtx, (b(:,i)),z,ierr) case('CSR') call lmbv_csr(dspmtx, (b(:,i)),z,ierr) case('DIA') call lmbv_dia(dspmtx, (b(:,i)),z,ierr) case('BCO') call lmbv_bco(dspmtx, (b(:,i)),z,ierr) case('BSC') call lmbv_bsc(dspmtx, (b(:,i)),z,ierr) case('BSR') call lmbv_bsr(dspmtx, (b(:,i)),z,ierr) case('BDI') call lmbv_bdi(dspmtx, (b(:,i)),z,ierr) case('VBR') call lmbv_vbr(dspmtx, (b(:,i)),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return else if(transa_work.eq.ORIGIN_MATRIX) then c(:,i) = alpha_work * z + c(:,i) else c(:,i) = alpha_work * ( (z)) + c(:,i) end if end if end do deallocate(z,STAT=ierr) end if ierr = 0 end subroutine susmm ! ********************************************************************** ! ********************************************************************** subroutine dusmm (a,b,c,ierr,transa,alpha) implicit none integer, intent(in) :: a real(KIND=dp) , dimension(:,:), intent(in) :: b real(KIND=dp) , dimension(:,:), intent(inout) :: c integer, intent(out) :: ierr integer, intent(in), optional :: transa real(KIND=dp) , intent(in), optional :: alpha real(KIND=dp) , dimension(:), allocatable :: z type(dspmat ), pointer :: dspmtx integer transa_work,i real(KIND=dp) :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. 0.0d0 ) then !no matrix multiplication necessary else call accessdata_dsp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(c,1)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,b(:,i),z,ierr) case('CSC') call rmbv_csc(dspmtx,b(:,i),z,ierr) case('CSR') call rmbv_csr(dspmtx,b(:,i),z,ierr) case('DIA') call rmbv_dia(dspmtx,b(:,i),z,ierr) case('BCO') call rmbv_bco(dspmtx,b(:,i),z,ierr) case('BSC') call rmbv_bsc(dspmtx,b(:,i),z,ierr) case('BSR') call rmbv_bsr(dspmtx,b(:,i),z,ierr) case('BDI') call rmbv_bdi(dspmtx,b(:,i),z,ierr) case('VBR') call rmbv_vbr(dspmtx,b(:,i),z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx, (b(:,i)),z,ierr) case('CSC') call lmbv_csc(dspmtx, (b(:,i)),z,ierr) case('CSR') call lmbv_csr(dspmtx, (b(:,i)),z,ierr) case('DIA') call lmbv_dia(dspmtx, (b(:,i)),z,ierr) case('BCO') call lmbv_bco(dspmtx, (b(:,i)),z,ierr) case('BSC') call lmbv_bsc(dspmtx, (b(:,i)),z,ierr) case('BSR') call lmbv_bsr(dspmtx, (b(:,i)),z,ierr) case('BDI') call lmbv_bdi(dspmtx, (b(:,i)),z,ierr) case('VBR') call lmbv_vbr(dspmtx, (b(:,i)),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return else if(transa_work.eq.ORIGIN_MATRIX) then c(:,i) = alpha_work * z + c(:,i) else c(:,i) = alpha_work * ( (z)) + c(:,i) end if end if end do deallocate(z,STAT=ierr) end if ierr = 0 end subroutine dusmm ! ********************************************************************** ! ********************************************************************** subroutine cusmm (a,b,c,ierr,transa,alpha) implicit none integer, intent(in) :: a complex(KIND=sp) , dimension(:,:), intent(in) :: b complex(KIND=sp) , dimension(:,:), intent(inout) :: c integer, intent(out) :: ierr integer, intent(in), optional :: transa complex(KIND=sp) , intent(in), optional :: alpha complex(KIND=sp) , dimension(:), allocatable :: z type(cspmat ), pointer :: dspmtx integer transa_work,i complex(KIND=sp) :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. (0.0e0, 0.0e0) ) then !no matrix multiplication necessary else call accessdata_csp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(c,1)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,b(:,i),z,ierr) case('CSC') call rmbv_csc(dspmtx,b(:,i),z,ierr) case('CSR') call rmbv_csr(dspmtx,b(:,i),z,ierr) case('DIA') call rmbv_dia(dspmtx,b(:,i),z,ierr) case('BCO') call rmbv_bco(dspmtx,b(:,i),z,ierr) case('BSC') call rmbv_bsc(dspmtx,b(:,i),z,ierr) case('BSR') call rmbv_bsr(dspmtx,b(:,i),z,ierr) case('BDI') call rmbv_bdi(dspmtx,b(:,i),z,ierr) case('VBR') call rmbv_vbr(dspmtx,b(:,i),z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx,conjg (b(:,i)),z,ierr) case('CSC') call lmbv_csc(dspmtx,conjg (b(:,i)),z,ierr) case('CSR') call lmbv_csr(dspmtx,conjg (b(:,i)),z,ierr) case('DIA') call lmbv_dia(dspmtx,conjg (b(:,i)),z,ierr) case('BCO') call lmbv_bco(dspmtx,conjg (b(:,i)),z,ierr) case('BSC') call lmbv_bsc(dspmtx,conjg (b(:,i)),z,ierr) case('BSR') call lmbv_bsr(dspmtx,conjg (b(:,i)),z,ierr) case('BDI') call lmbv_bdi(dspmtx,conjg (b(:,i)),z,ierr) case('VBR') call lmbv_vbr(dspmtx,conjg (b(:,i)),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return else if(transa_work.eq.ORIGIN_MATRIX) then c(:,i) = alpha_work * z + c(:,i) else c(:,i) = alpha_work * (conjg (z)) + c(:,i) end if end if end do deallocate(z,STAT=ierr) end if ierr = 0 end subroutine cusmm ! ********************************************************************** ! ********************************************************************** subroutine zusmm (a,b,c,ierr,transa,alpha) implicit none integer, intent(in) :: a complex(KIND=dp) , dimension(:,:), intent(in) :: b complex(KIND=dp) , dimension(:,:), intent(inout) :: c integer, intent(out) :: ierr integer, intent(in), optional :: transa complex(KIND=dp) , intent(in), optional :: alpha complex(KIND=dp) , dimension(:), allocatable :: z type(zspmat ), pointer :: dspmtx integer transa_work,i complex(KIND=dp) :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. (0.0d0, 0.0d0) ) then !no matrix multiplication necessary else call accessdata_zsp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(c,1)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,b(:,i),z,ierr) case('CSC') call rmbv_csc(dspmtx,b(:,i),z,ierr) case('CSR') call rmbv_csr(dspmtx,b(:,i),z,ierr) case('DIA') call rmbv_dia(dspmtx,b(:,i),z,ierr) case('BCO') call rmbv_bco(dspmtx,b(:,i),z,ierr) case('BSC') call rmbv_bsc(dspmtx,b(:,i),z,ierr) case('BSR') call rmbv_bsr(dspmtx,b(:,i),z,ierr) case('BDI') call rmbv_bdi(dspmtx,b(:,i),z,ierr) case('VBR') call rmbv_vbr(dspmtx,b(:,i),z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx,conjg (b(:,i)),z,ierr) case('CSC') call lmbv_csc(dspmtx,conjg (b(:,i)),z,ierr) case('CSR') call lmbv_csr(dspmtx,conjg (b(:,i)),z,ierr) case('DIA') call lmbv_dia(dspmtx,conjg (b(:,i)),z,ierr) case('BCO') call lmbv_bco(dspmtx,conjg (b(:,i)),z,ierr) case('BSC') call lmbv_bsc(dspmtx,conjg (b(:,i)),z,ierr) case('BSR') call lmbv_bsr(dspmtx,conjg (b(:,i)),z,ierr) case('BDI') call lmbv_bdi(dspmtx,conjg (b(:,i)),z,ierr) case('VBR') call lmbv_vbr(dspmtx,conjg (b(:,i)),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return else if(transa_work.eq.ORIGIN_MATRIX) then c(:,i) = alpha_work * z + c(:,i) else c(:,i) = alpha_work * (conjg (z)) + c(:,i) end if end if end do deallocate(z,STAT=ierr) end if ierr = 0 end subroutine zusmm ! ********************************************************************** ! ********************************************************************** end module mod_usmm SHAR_EOF fi # end of overwriting check if test -f 'usmv.f90' then echo shar: will not over-write existing file "'usmv.f90'" else cat << "SHAR_EOF" > 'usmv.f90' module mod_usmv ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : MV MULTIPLICATION, CHOOSES APPROPRIATE SUBROUTINES ! ********************************************************************** use representation_of_data use properties use mod_mbv implicit none interface usmv module procedure iusmv module procedure susmv module procedure dusmv module procedure cusmv module procedure zusmv end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iusmv (a,x,y,ierr,transa,alpha) implicit none integer, intent(in) :: a integer , dimension(:), intent(in) :: x integer , dimension(:), intent(inout) :: y integer, intent(out) :: ierr integer, intent(in), optional :: transa integer , intent(in), optional :: alpha integer , dimension(:), allocatable :: z type(ispmat ), pointer :: dspmtx integer :: transa_work integer :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. 0 ) then !no matrix multiplication necessary else call accessdata_isp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(y)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,x,z,ierr) case('CSC') call rmbv_csc(dspmtx,x,z,ierr) case('CSR') call rmbv_csr(dspmtx,x,z,ierr) case('DIA') call rmbv_dia(dspmtx,x,z,ierr) case('BCO') call rmbv_bco(dspmtx,x,z,ierr) case('BSC') call rmbv_bsc(dspmtx,x,z,ierr) case('BSR') call rmbv_bsr(dspmtx,x,z,ierr) case('BDI') call rmbv_bdi(dspmtx,x,z,ierr) case('VBR') call rmbv_vbr(dspmtx,x,z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx, (x),z,ierr) case('CSC') call lmbv_csc(dspmtx, (x),z,ierr) case('CSR') call lmbv_csr(dspmtx, (x),z,ierr) case('DIA') call lmbv_dia(dspmtx, (x),z,ierr) case('BCO') call lmbv_bco(dspmtx, (x),z,ierr) case('BSC') call lmbv_bsc(dspmtx, (x),z,ierr) case('BSR') call lmbv_bsr(dspmtx, (x),z,ierr) case('BDI') call lmbv_bdi(dspmtx, (x),z,ierr) case('VBR') call lmbv_vbr(dspmtx, (x),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return end if if(transa_work.eq.ORIGIN_MATRIX) then y = alpha_work * z + y else y = alpha_work * ( (z)) + y end if deallocate(z,STAT=ierr) end if ierr = 0 end subroutine iusmv ! ********************************************************************** ! ********************************************************************** subroutine susmv (a,x,y,ierr,transa,alpha) implicit none integer, intent(in) :: a real(KIND=sp) , dimension(:), intent(in) :: x real(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(out) :: ierr integer, intent(in), optional :: transa real(KIND=sp) , intent(in), optional :: alpha real(KIND=sp) , dimension(:), allocatable :: z type(sspmat ), pointer :: dspmtx integer :: transa_work real(KIND=sp) :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. 0.0e0 ) then !no matrix multiplication necessary else call accessdata_ssp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(y)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,x,z,ierr) case('CSC') call rmbv_csc(dspmtx,x,z,ierr) case('CSR') call rmbv_csr(dspmtx,x,z,ierr) case('DIA') call rmbv_dia(dspmtx,x,z,ierr) case('BCO') call rmbv_bco(dspmtx,x,z,ierr) case('BSC') call rmbv_bsc(dspmtx,x,z,ierr) case('BSR') call rmbv_bsr(dspmtx,x,z,ierr) case('BDI') call rmbv_bdi(dspmtx,x,z,ierr) case('VBR') call rmbv_vbr(dspmtx,x,z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx, (x),z,ierr) case('CSC') call lmbv_csc(dspmtx, (x),z,ierr) case('CSR') call lmbv_csr(dspmtx, (x),z,ierr) case('DIA') call lmbv_dia(dspmtx, (x),z,ierr) case('BCO') call lmbv_bco(dspmtx, (x),z,ierr) case('BSC') call lmbv_bsc(dspmtx, (x),z,ierr) case('BSR') call lmbv_bsr(dspmtx, (x),z,ierr) case('BDI') call lmbv_bdi(dspmtx, (x),z,ierr) case('VBR') call lmbv_vbr(dspmtx, (x),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return end if if(transa_work.eq.ORIGIN_MATRIX) then y = alpha_work * z + y else y = alpha_work * ( (z)) + y end if deallocate(z,STAT=ierr) end if ierr = 0 end subroutine susmv ! ********************************************************************** ! ********************************************************************** subroutine dusmv (a,x,y,ierr,transa,alpha) implicit none integer, intent(in) :: a real(KIND=dp) , dimension(:), intent(in) :: x real(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(out) :: ierr integer, intent(in), optional :: transa real(KIND=dp) , intent(in), optional :: alpha real(KIND=dp) , dimension(:), allocatable :: z type(dspmat ), pointer :: dspmtx integer :: transa_work real(KIND=dp) :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. 0.0d0 ) then !no matrix multiplication necessary else call accessdata_dsp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(y)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,x,z,ierr) case('CSC') call rmbv_csc(dspmtx,x,z,ierr) case('CSR') call rmbv_csr(dspmtx,x,z,ierr) case('DIA') call rmbv_dia(dspmtx,x,z,ierr) case('BCO') call rmbv_bco(dspmtx,x,z,ierr) case('BSC') call rmbv_bsc(dspmtx,x,z,ierr) case('BSR') call rmbv_bsr(dspmtx,x,z,ierr) case('BDI') call rmbv_bdi(dspmtx,x,z,ierr) case('VBR') call rmbv_vbr(dspmtx,x,z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx, (x),z,ierr) case('CSC') call lmbv_csc(dspmtx, (x),z,ierr) case('CSR') call lmbv_csr(dspmtx, (x),z,ierr) case('DIA') call lmbv_dia(dspmtx, (x),z,ierr) case('BCO') call lmbv_bco(dspmtx, (x),z,ierr) case('BSC') call lmbv_bsc(dspmtx, (x),z,ierr) case('BSR') call lmbv_bsr(dspmtx, (x),z,ierr) case('BDI') call lmbv_bdi(dspmtx, (x),z,ierr) case('VBR') call lmbv_vbr(dspmtx, (x),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return end if if(transa_work.eq.ORIGIN_MATRIX) then y = alpha_work * z + y else y = alpha_work * ( (z)) + y end if deallocate(z,STAT=ierr) end if ierr = 0 end subroutine dusmv ! ********************************************************************** ! ********************************************************************** subroutine cusmv (a,x,y,ierr,transa,alpha) implicit none integer, intent(in) :: a complex(KIND=sp) , dimension(:), intent(in) :: x complex(KIND=sp) , dimension(:), intent(inout) :: y integer, intent(out) :: ierr integer, intent(in), optional :: transa complex(KIND=sp) , intent(in), optional :: alpha complex(KIND=sp) , dimension(:), allocatable :: z type(cspmat ), pointer :: dspmtx integer :: transa_work complex(KIND=sp) :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. (0.0e0, 0.0e0) ) then !no matrix multiplication necessary else call accessdata_csp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(y)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,x,z,ierr) case('CSC') call rmbv_csc(dspmtx,x,z,ierr) case('CSR') call rmbv_csr(dspmtx,x,z,ierr) case('DIA') call rmbv_dia(dspmtx,x,z,ierr) case('BCO') call rmbv_bco(dspmtx,x,z,ierr) case('BSC') call rmbv_bsc(dspmtx,x,z,ierr) case('BSR') call rmbv_bsr(dspmtx,x,z,ierr) case('BDI') call rmbv_bdi(dspmtx,x,z,ierr) case('VBR') call rmbv_vbr(dspmtx,x,z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx,conjg (x),z,ierr) case('CSC') call lmbv_csc(dspmtx,conjg (x),z,ierr) case('CSR') call lmbv_csr(dspmtx,conjg (x),z,ierr) case('DIA') call lmbv_dia(dspmtx,conjg (x),z,ierr) case('BCO') call lmbv_bco(dspmtx,conjg (x),z,ierr) case('BSC') call lmbv_bsc(dspmtx,conjg (x),z,ierr) case('BSR') call lmbv_bsr(dspmtx,conjg (x),z,ierr) case('BDI') call lmbv_bdi(dspmtx,conjg (x),z,ierr) case('VBR') call lmbv_vbr(dspmtx,conjg (x),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return end if if(transa_work.eq.ORIGIN_MATRIX) then y = alpha_work * z + y else y = alpha_work * (conjg (z)) + y end if deallocate(z,STAT=ierr) end if ierr = 0 end subroutine cusmv ! ********************************************************************** ! ********************************************************************** subroutine zusmv (a,x,y,ierr,transa,alpha) implicit none integer, intent(in) :: a complex(KIND=dp) , dimension(:), intent(in) :: x complex(KIND=dp) , dimension(:), intent(inout) :: y integer, intent(out) :: ierr integer, intent(in), optional :: transa complex(KIND=dp) , intent(in), optional :: alpha complex(KIND=dp) , dimension(:), allocatable :: z type(zspmat ), pointer :: dspmtx integer :: transa_work complex(KIND=dp) :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq. (0.0d0, 0.0d0) ) then !no matrix multiplication necessary else call accessdata_zsp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(y)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,x,z,ierr) case('CSC') call rmbv_csc(dspmtx,x,z,ierr) case('CSR') call rmbv_csr(dspmtx,x,z,ierr) case('DIA') call rmbv_dia(dspmtx,x,z,ierr) case('BCO') call rmbv_bco(dspmtx,x,z,ierr) case('BSC') call rmbv_bsc(dspmtx,x,z,ierr) case('BSR') call rmbv_bsr(dspmtx,x,z,ierr) case('BDI') call rmbv_bdi(dspmtx,x,z,ierr) case('VBR') call rmbv_vbr(dspmtx,x,z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx,conjg (x),z,ierr) case('CSC') call lmbv_csc(dspmtx,conjg (x),z,ierr) case('CSR') call lmbv_csr(dspmtx,conjg (x),z,ierr) case('DIA') call lmbv_dia(dspmtx,conjg (x),z,ierr) case('BCO') call lmbv_bco(dspmtx,conjg (x),z,ierr) case('BSC') call lmbv_bsc(dspmtx,conjg (x),z,ierr) case('BSR') call lmbv_bsr(dspmtx,conjg (x),z,ierr) case('BDI') call lmbv_bdi(dspmtx,conjg (x),z,ierr) case('VBR') call lmbv_vbr(dspmtx,conjg (x),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return end if if(transa_work.eq.ORIGIN_MATRIX) then y = alpha_work * z + y else y = alpha_work * (conjg (z)) + y end if deallocate(z,STAT=ierr) end if ierr = 0 end subroutine zusmv ! ********************************************************************** ! ********************************************************************** end module mod_usmv SHAR_EOF fi # end of overwriting check if test -f 'ussc.f90' then echo shar: will not over-write existing file "'ussc.f90'" else cat << "SHAR_EOF" > 'ussc.f90' module mod_ussc use blas_sparse_namedconstants interface ussc module procedure iussc module procedure sussc module procedure dussc module procedure cussc module procedure zussc end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iussc (x,y,indx) integer ,dimension(:),intent(in) ::x integer ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer :: i,t t=size(indx) if(t.gt.0) then do i=1,t y(indx(i))= x(i) end do end if end subroutine iussc ! ********************************************************************** ! ********************************************************************** subroutine sussc (x,y,indx) real(KIND=sp) ,dimension(:),intent(in) ::x real(KIND=sp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer :: i,t t=size(indx) if(t.gt.0) then do i=1,t y(indx(i))= x(i) end do end if end subroutine sussc ! ********************************************************************** ! ********************************************************************** subroutine dussc (x,y,indx) real(KIND=dp) ,dimension(:),intent(in) ::x real(KIND=dp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer :: i,t t=size(indx) if(t.gt.0) then do i=1,t y(indx(i))= x(i) end do end if end subroutine dussc ! ********************************************************************** ! ********************************************************************** subroutine cussc (x,y,indx) complex(KIND=sp) ,dimension(:),intent(in) ::x complex(KIND=sp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer :: i,t t=size(indx) if(t.gt.0) then do i=1,t y(indx(i))= x(i) end do end if end subroutine cussc ! ********************************************************************** ! ********************************************************************** subroutine zussc (x,y,indx) complex(KIND=dp) ,dimension(:),intent(in) ::x complex(KIND=dp) ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer :: i,t t=size(indx) if(t.gt.0) then do i=1,t y(indx(i))= x(i) end do end if end subroutine zussc ! ********************************************************************** ! ********************************************************************** end module mod_ussc SHAR_EOF fi # end of overwriting check if test -f 'ussm.f90' then echo shar: will not over-write existing file "'ussm.f90'" else cat << "SHAR_EOF" > 'ussm.f90' module mod_ussm ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : TRI. SOLVE, CHOOSES APPROPRIATE SUBROUTINES ! ********************************************************************** use representation_of_data use properties use mod_sbv implicit none interface ussm module procedure iussm module procedure sussm module procedure dussm module procedure cussm module procedure zussm end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iussm (a,b,ierr,transa,alpha) integer, intent(in) :: a integer , dimension(:,:), intent(inout) :: b integer, intent(out) :: ierr integer, intent(in), optional :: transa integer , intent(in), optional :: alpha integer :: transa_work,i integer :: alpha_work integer , dimension(:,:), allocatable :: z type(ispmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne.0.) then call accessdata_isp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(b,1),size(b,2)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= (b) do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,b(:,i),ierr) case('CSC') call rsbv_csc(dspmtx,b(:,i),ierr) case('CSR') call rsbv_csr(dspmtx,b(:,i),ierr) case('DIA') call rsbv_dia(dspmtx,b(:,i),ierr) case('BCO') call rsbv_bco(dspmtx,b(:,i),ierr) case('BSC') call rsbv_bsc(dspmtx,b(:,i),ierr) case('BSR') call rsbv_bsr(dspmtx,b(:,i),ierr) case('BDI') call rsbv_bdi(dspmtx,b(:,i),ierr) case('VBR') call rsbv_vbr(dspmtx,b(:,i),ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z(:,i),ierr) case('CSC') call lsbv_csc(dspmtx,z(:,i),ierr) case('CSR') call lsbv_csr(dspmtx,z(:,i),ierr) case('DIA') call lsbv_dia(dspmtx,z(:,i),ierr) case('BCO') call lsbv_bco(dspmtx,z(:,i),ierr) case('BSC') call lsbv_bsc(dspmtx,z(:,i),ierr) case('BSR') call lsbv_bsr(dspmtx,z(:,i),ierr) case('BDI') call lsbv_bdi(dspmtx,z(:,i),ierr) case('VBR') call lsbv_vbr(dspmtx,z(:,i),ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end do end if if(transa_work.eq.ORIGIN_MATRIX) then b = alpha_work * b else b = alpha_work * ( (z)) end if ierr = 0 end subroutine iussm ! ********************************************************************** ! ********************************************************************** subroutine sussm (a,b,ierr,transa,alpha) integer, intent(in) :: a real(KIND=sp) , dimension(:,:), intent(inout) :: b integer, intent(out) :: ierr integer, intent(in), optional :: transa real(KIND=sp) , intent(in), optional :: alpha integer :: transa_work,i real(KIND=sp) :: alpha_work real(KIND=sp) , dimension(:,:), allocatable :: z type(sspmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne.0.) then call accessdata_ssp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(b,1),size(b,2)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= (b) do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,b(:,i),ierr) case('CSC') call rsbv_csc(dspmtx,b(:,i),ierr) case('CSR') call rsbv_csr(dspmtx,b(:,i),ierr) case('DIA') call rsbv_dia(dspmtx,b(:,i),ierr) case('BCO') call rsbv_bco(dspmtx,b(:,i),ierr) case('BSC') call rsbv_bsc(dspmtx,b(:,i),ierr) case('BSR') call rsbv_bsr(dspmtx,b(:,i),ierr) case('BDI') call rsbv_bdi(dspmtx,b(:,i),ierr) case('VBR') call rsbv_vbr(dspmtx,b(:,i),ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z(:,i),ierr) case('CSC') call lsbv_csc(dspmtx,z(:,i),ierr) case('CSR') call lsbv_csr(dspmtx,z(:,i),ierr) case('DIA') call lsbv_dia(dspmtx,z(:,i),ierr) case('BCO') call lsbv_bco(dspmtx,z(:,i),ierr) case('BSC') call lsbv_bsc(dspmtx,z(:,i),ierr) case('BSR') call lsbv_bsr(dspmtx,z(:,i),ierr) case('BDI') call lsbv_bdi(dspmtx,z(:,i),ierr) case('VBR') call lsbv_vbr(dspmtx,z(:,i),ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end do end if if(transa_work.eq.ORIGIN_MATRIX) then b = alpha_work * b else b = alpha_work * ( (z)) end if ierr = 0 end subroutine sussm ! ********************************************************************** ! ********************************************************************** subroutine dussm (a,b,ierr,transa,alpha) integer, intent(in) :: a real(KIND=dp) , dimension(:,:), intent(inout) :: b integer, intent(out) :: ierr integer, intent(in), optional :: transa real(KIND=dp) , intent(in), optional :: alpha integer :: transa_work,i real(KIND=dp) :: alpha_work real(KIND=dp) , dimension(:,:), allocatable :: z type(dspmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne.0.) then call accessdata_dsp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(b,1),size(b,2)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= (b) do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,b(:,i),ierr) case('CSC') call rsbv_csc(dspmtx,b(:,i),ierr) case('CSR') call rsbv_csr(dspmtx,b(:,i),ierr) case('DIA') call rsbv_dia(dspmtx,b(:,i),ierr) case('BCO') call rsbv_bco(dspmtx,b(:,i),ierr) case('BSC') call rsbv_bsc(dspmtx,b(:,i),ierr) case('BSR') call rsbv_bsr(dspmtx,b(:,i),ierr) case('BDI') call rsbv_bdi(dspmtx,b(:,i),ierr) case('VBR') call rsbv_vbr(dspmtx,b(:,i),ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z(:,i),ierr) case('CSC') call lsbv_csc(dspmtx,z(:,i),ierr) case('CSR') call lsbv_csr(dspmtx,z(:,i),ierr) case('DIA') call lsbv_dia(dspmtx,z(:,i),ierr) case('BCO') call lsbv_bco(dspmtx,z(:,i),ierr) case('BSC') call lsbv_bsc(dspmtx,z(:,i),ierr) case('BSR') call lsbv_bsr(dspmtx,z(:,i),ierr) case('BDI') call lsbv_bdi(dspmtx,z(:,i),ierr) case('VBR') call lsbv_vbr(dspmtx,z(:,i),ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end do end if if(transa_work.eq.ORIGIN_MATRIX) then b = alpha_work * b else b = alpha_work * ( (z)) end if ierr = 0 end subroutine dussm ! ********************************************************************** ! ********************************************************************** subroutine cussm (a,b,ierr,transa,alpha) integer, intent(in) :: a complex(KIND=sp) , dimension(:,:), intent(inout) :: b integer, intent(out) :: ierr integer, intent(in), optional :: transa complex(KIND=sp) , intent(in), optional :: alpha integer :: transa_work,i complex(KIND=sp) :: alpha_work complex(KIND=sp) , dimension(:,:), allocatable :: z type(cspmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne.0.) then call accessdata_csp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(b,1),size(b,2)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= conjg (b) do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,b(:,i),ierr) case('CSC') call rsbv_csc(dspmtx,b(:,i),ierr) case('CSR') call rsbv_csr(dspmtx,b(:,i),ierr) case('DIA') call rsbv_dia(dspmtx,b(:,i),ierr) case('BCO') call rsbv_bco(dspmtx,b(:,i),ierr) case('BSC') call rsbv_bsc(dspmtx,b(:,i),ierr) case('BSR') call rsbv_bsr(dspmtx,b(:,i),ierr) case('BDI') call rsbv_bdi(dspmtx,b(:,i),ierr) case('VBR') call rsbv_vbr(dspmtx,b(:,i),ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z(:,i),ierr) case('CSC') call lsbv_csc(dspmtx,z(:,i),ierr) case('CSR') call lsbv_csr(dspmtx,z(:,i),ierr) case('DIA') call lsbv_dia(dspmtx,z(:,i),ierr) case('BCO') call lsbv_bco(dspmtx,z(:,i),ierr) case('BSC') call lsbv_bsc(dspmtx,z(:,i),ierr) case('BSR') call lsbv_bsr(dspmtx,z(:,i),ierr) case('BDI') call lsbv_bdi(dspmtx,z(:,i),ierr) case('VBR') call lsbv_vbr(dspmtx,z(:,i),ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end do end if if(transa_work.eq.ORIGIN_MATRIX) then b = alpha_work * b else b = alpha_work * (conjg (z)) end if ierr = 0 end subroutine cussm ! ********************************************************************** ! ********************************************************************** subroutine zussm (a,b,ierr,transa,alpha) integer, intent(in) :: a complex(KIND=dp) , dimension(:,:), intent(inout) :: b integer, intent(out) :: ierr integer, intent(in), optional :: transa complex(KIND=dp) , intent(in), optional :: alpha integer :: transa_work,i complex(KIND=dp) :: alpha_work complex(KIND=dp) , dimension(:,:), allocatable :: z type(zspmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne.0.) then call accessdata_zsp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(b,1),size(b,2)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= conjg (b) do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,b(:,i),ierr) case('CSC') call rsbv_csc(dspmtx,b(:,i),ierr) case('CSR') call rsbv_csr(dspmtx,b(:,i),ierr) case('DIA') call rsbv_dia(dspmtx,b(:,i),ierr) case('BCO') call rsbv_bco(dspmtx,b(:,i),ierr) case('BSC') call rsbv_bsc(dspmtx,b(:,i),ierr) case('BSR') call rsbv_bsr(dspmtx,b(:,i),ierr) case('BDI') call rsbv_bdi(dspmtx,b(:,i),ierr) case('VBR') call rsbv_vbr(dspmtx,b(:,i),ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z(:,i),ierr) case('CSC') call lsbv_csc(dspmtx,z(:,i),ierr) case('CSR') call lsbv_csr(dspmtx,z(:,i),ierr) case('DIA') call lsbv_dia(dspmtx,z(:,i),ierr) case('BCO') call lsbv_bco(dspmtx,z(:,i),ierr) case('BSC') call lsbv_bsc(dspmtx,z(:,i),ierr) case('BSR') call lsbv_bsr(dspmtx,z(:,i),ierr) case('BDI') call lsbv_bdi(dspmtx,z(:,i),ierr) case('VBR') call lsbv_vbr(dspmtx,z(:,i),ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end do end if if(transa_work.eq.ORIGIN_MATRIX) then b = alpha_work * b else b = alpha_work * (conjg (z)) end if ierr = 0 end subroutine zussm ! ********************************************************************** ! ********************************************************************** end module mod_ussm SHAR_EOF fi # end of overwriting check if test -f 'ussp.f90' then echo shar: will not over-write existing file "'ussp.f90'" else cat << "SHAR_EOF" > 'ussp.f90' module mod_ussp use mod_INSERTING use properties contains subroutine ussp(a,m,istat) implicit none integer ,intent(inout)::a integer,intent(in)::m integer, intent(out)::istat integer::b,rest type(i_matrix),pointer ::ipmatrix type(d_matrix),pointer ::dpmatrix type(s_matrix),pointer ::spmatrix type(c_matrix),pointer ::cpmatrix type(z_matrix),pointer ::zpmatrix b=-a istat = 0 rest = modulo(b,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** call access_matrix(ipmatrix ,a,istat) ipmatrix %property=m ! ********************************************************************** !!*************************************************************************** case(SSP_MATRIX) ! ********************************************************************** call access_matrix(spmatrix ,a,istat) spmatrix %property=m ! ********************************************************************** !!*************************************************************************** case(DSP_MATRIX) ! ********************************************************************** call access_matrix(dpmatrix ,a,istat) dpmatrix %property=m ! ********************************************************************** !!*************************************************************************** case(CSP_MATRIX) ! ********************************************************************** call access_matrix(cpmatrix ,a,istat) cpmatrix %property=m ! ********************************************************************** !!*************************************************************************** case(ZSP_MATRIX) ! ********************************************************************** call access_matrix(zpmatrix ,a,istat) zpmatrix %property=m ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** case default istat = blas_error_param return end select end subroutine ussp end module mod_ussp SHAR_EOF fi # end of overwriting check if test -f 'ussv.f90' then echo shar: will not over-write existing file "'ussv.f90'" else cat << "SHAR_EOF" > 'ussv.f90' module mod_ussv ! ********************************************************************** ! Author : C. Voemel ! Date of last modification : 7.7.00 ! Description : TRI. SOLVE, CHOOSES APPROPRIATE SUBROUTINES ! ********************************************************************** use representation_of_data use properties use mod_sbv implicit none interface ussv module procedure iussv module procedure sussv module procedure dussv module procedure cussv module procedure zussv end interface contains ! ********************************************************************** ! ********************************************************************** subroutine iussv (a,x,ierr,transa,alpha) integer, intent(in) :: a integer , intent(inout) :: x(:) integer, intent(out) :: ierr integer, intent(in), optional :: transa integer , intent(in), optional :: alpha integer :: transa_work integer :: alpha_work integer , dimension(:), allocatable :: z type(ispmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne. 0 ) then call accessdata_isp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(x)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= (x) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,x,ierr) case('CSC') call rsbv_csc(dspmtx,x,ierr) case('CSR') call rsbv_csr(dspmtx,x,ierr) case('DIA') call rsbv_dia(dspmtx,x,ierr) case('BCO') call rsbv_bco(dspmtx,x,ierr) case('BSC') call rsbv_bsc(dspmtx,x,ierr) case('BSR') call rsbv_bsr(dspmtx,x,ierr) case('BDI') call rsbv_bdi(dspmtx,x,ierr) case('VBR') call rsbv_vbr(dspmtx,x,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z,ierr) case('CSC') call lsbv_csc(dspmtx,z,ierr) case('CSR') call lsbv_csr(dspmtx,z,ierr) case('DIA') call lsbv_dia(dspmtx,z,ierr) case('BCO') call lsbv_bco(dspmtx,z,ierr) case('BSC') call lsbv_bsc(dspmtx,z,ierr) case('BSR') call lsbv_bsr(dspmtx,z,ierr) case('BDI') call lsbv_bdi(dspmtx,z,ierr) case('VBR') call lsbv_vbr(dspmtx,z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end if if(transa_work.eq.ORIGIN_MATRIX) then x = alpha_work * x else x = alpha_work * ( (z)) end if ierr = 0 end subroutine iussv ! ********************************************************************** ! ********************************************************************** subroutine sussv (a,x,ierr,transa,alpha) integer, intent(in) :: a real(KIND=sp) , intent(inout) :: x(:) integer, intent(out) :: ierr integer, intent(in), optional :: transa real(KIND=sp) , intent(in), optional :: alpha integer :: transa_work real(KIND=sp) :: alpha_work real(KIND=sp) , dimension(:), allocatable :: z type(sspmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne. 0.0e0 ) then call accessdata_ssp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(x)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= (x) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,x,ierr) case('CSC') call rsbv_csc(dspmtx,x,ierr) case('CSR') call rsbv_csr(dspmtx,x,ierr) case('DIA') call rsbv_dia(dspmtx,x,ierr) case('BCO') call rsbv_bco(dspmtx,x,ierr) case('BSC') call rsbv_bsc(dspmtx,x,ierr) case('BSR') call rsbv_bsr(dspmtx,x,ierr) case('BDI') call rsbv_bdi(dspmtx,x,ierr) case('VBR') call rsbv_vbr(dspmtx,x,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z,ierr) case('CSC') call lsbv_csc(dspmtx,z,ierr) case('CSR') call lsbv_csr(dspmtx,z,ierr) case('DIA') call lsbv_dia(dspmtx,z,ierr) case('BCO') call lsbv_bco(dspmtx,z,ierr) case('BSC') call lsbv_bsc(dspmtx,z,ierr) case('BSR') call lsbv_bsr(dspmtx,z,ierr) case('BDI') call lsbv_bdi(dspmtx,z,ierr) case('VBR') call lsbv_vbr(dspmtx,z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end if if(transa_work.eq.ORIGIN_MATRIX) then x = alpha_work * x else x = alpha_work * ( (z)) end if ierr = 0 end subroutine sussv ! ********************************************************************** ! ********************************************************************** subroutine dussv (a,x,ierr,transa,alpha) integer, intent(in) :: a real(KIND=dp) , intent(inout) :: x(:) integer, intent(out) :: ierr integer, intent(in), optional :: transa real(KIND=dp) , intent(in), optional :: alpha integer :: transa_work real(KIND=dp) :: alpha_work real(KIND=dp) , dimension(:), allocatable :: z type(dspmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne. 0.0d0 ) then call accessdata_dsp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(x)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= (x) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,x,ierr) case('CSC') call rsbv_csc(dspmtx,x,ierr) case('CSR') call rsbv_csr(dspmtx,x,ierr) case('DIA') call rsbv_dia(dspmtx,x,ierr) case('BCO') call rsbv_bco(dspmtx,x,ierr) case('BSC') call rsbv_bsc(dspmtx,x,ierr) case('BSR') call rsbv_bsr(dspmtx,x,ierr) case('BDI') call rsbv_bdi(dspmtx,x,ierr) case('VBR') call rsbv_vbr(dspmtx,x,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z,ierr) case('CSC') call lsbv_csc(dspmtx,z,ierr) case('CSR') call lsbv_csr(dspmtx,z,ierr) case('DIA') call lsbv_dia(dspmtx,z,ierr) case('BCO') call lsbv_bco(dspmtx,z,ierr) case('BSC') call lsbv_bsc(dspmtx,z,ierr) case('BSR') call lsbv_bsr(dspmtx,z,ierr) case('BDI') call lsbv_bdi(dspmtx,z,ierr) case('VBR') call lsbv_vbr(dspmtx,z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end if if(transa_work.eq.ORIGIN_MATRIX) then x = alpha_work * x else x = alpha_work * ( (z)) end if ierr = 0 end subroutine dussv ! ********************************************************************** ! ********************************************************************** subroutine cussv (a,x,ierr,transa,alpha) integer, intent(in) :: a complex(KIND=sp) , intent(inout) :: x(:) integer, intent(out) :: ierr integer, intent(in), optional :: transa complex(KIND=sp) , intent(in), optional :: alpha integer :: transa_work complex(KIND=sp) :: alpha_work complex(KIND=sp) , dimension(:), allocatable :: z type(cspmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne. (0.0e0, 0.0e0) ) then call accessdata_csp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(x)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= conjg (x) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,x,ierr) case('CSC') call rsbv_csc(dspmtx,x,ierr) case('CSR') call rsbv_csr(dspmtx,x,ierr) case('DIA') call rsbv_dia(dspmtx,x,ierr) case('BCO') call rsbv_bco(dspmtx,x,ierr) case('BSC') call rsbv_bsc(dspmtx,x,ierr) case('BSR') call rsbv_bsr(dspmtx,x,ierr) case('BDI') call rsbv_bdi(dspmtx,x,ierr) case('VBR') call rsbv_vbr(dspmtx,x,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z,ierr) case('CSC') call lsbv_csc(dspmtx,z,ierr) case('CSR') call lsbv_csr(dspmtx,z,ierr) case('DIA') call lsbv_dia(dspmtx,z,ierr) case('BCO') call lsbv_bco(dspmtx,z,ierr) case('BSC') call lsbv_bsc(dspmtx,z,ierr) case('BSR') call lsbv_bsr(dspmtx,z,ierr) case('BDI') call lsbv_bdi(dspmtx,z,ierr) case('VBR') call lsbv_vbr(dspmtx,z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end if if(transa_work.eq.ORIGIN_MATRIX) then x = alpha_work * x else x = alpha_work * (conjg (z)) end if ierr = 0 end subroutine cussv ! ********************************************************************** ! ********************************************************************** subroutine zussv (a,x,ierr,transa,alpha) integer, intent(in) :: a complex(KIND=dp) , intent(inout) :: x(:) integer, intent(out) :: ierr integer, intent(in), optional :: transa complex(KIND=dp) , intent(in), optional :: alpha integer :: transa_work complex(KIND=dp) :: alpha_work complex(KIND=dp) , dimension(:), allocatable :: z type(zspmat ), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne. (0.0d0, 0.0d0) ) then call accessdata_zsp (dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(x)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z= conjg (x) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,x,ierr) case('CSC') call rsbv_csc(dspmtx,x,ierr) case('CSR') call rsbv_csr(dspmtx,x,ierr) case('DIA') call rsbv_dia(dspmtx,x,ierr) case('BCO') call rsbv_bco(dspmtx,x,ierr) case('BSC') call rsbv_bsc(dspmtx,x,ierr) case('BSR') call rsbv_bsr(dspmtx,x,ierr) case('BDI') call rsbv_bdi(dspmtx,x,ierr) case('VBR') call rsbv_vbr(dspmtx,x,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z,ierr) case('CSC') call lsbv_csc(dspmtx,z,ierr) case('CSR') call lsbv_csr(dspmtx,z,ierr) case('DIA') call lsbv_dia(dspmtx,z,ierr) case('BCO') call lsbv_bco(dspmtx,z,ierr) case('BSC') call lsbv_bsc(dspmtx,z,ierr) case('BSR') call lsbv_bsr(dspmtx,z,ierr) case('BDI') call lsbv_bdi(dspmtx,z,ierr) case('VBR') call lsbv_vbr(dspmtx,z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end if if(transa_work.eq.ORIGIN_MATRIX) then x = alpha_work * x else x = alpha_work * (conjg (z)) end if ierr = 0 end subroutine zussv ! ********************************************************************** ! ********************************************************************** end module mod_ussv SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'SOURCE_FILES' then mkdir 'SOURCE_FILES' fi cd 'SOURCE_FILES' if test -f 'INSERTING_source.F' then echo shar: will not over-write existing file "'INSERTING_source.F'" else cat << "SHAR_EOF" > 'INSERTING_source.F' subroutine NEW_X_MATRIX(nmb,Mb,ierr) implicit none integer ,intent(out)::nmb,ierr integer ,intent(in)::Mb type(X_MATRIX),pointer::matrix_insert if (.NOT.XINS_INIT) then nullify(X_MATRIX_start) XINS_INIT = .TRUE. end if if (.not.associated(X_MATRIX_start)) then allocate(X_MATRIX_start,STAT=ierr) X_MATRIX_start%number=XSP_MATRIX X_MATRIX_start%number=-X_MATRIX_start%number nullify(X_MATRIX_start%pntr) else allocate(matrix_insert,STAT=ierr) matrix_insert%number=X_MATRIX_start%number-no_of_types matrix_insert%pntr=>X_MATRIX_start X_MATRIX_start=> matrix_insert end if X_MATRIX_start%DIM=0 X_MATRIX_start%property=blas_general+blas_one_base+blas_col_major X_MATRIX_start%new = 1 !new=0:blas_open_handle, new=1: blas_new_handle X_MATRIX_start%format='' nullify(X_MATRIX_start%sub_rows,X_MATRIX_start%sub_cols) nullify(X_MATRIX_start%X_ELEMENT_start) allocate(X_MATRIX_start%trb(Mb),X_MATRIX_start%tre(Mb)) nmb=X_MATRIX_start%number ierr=0 end subroutine NEW_X_MATRIX !!! !* !!! subroutine DELOC_X_MATRIX (nmb,ierr) implicit none integer ,intent(in)::nmb integer ,intent(out)::ierr type(X_MATRIX),pointer ::matrix_precedent,matrix_tester ierr=-1 if(.not.associated(X_MATRIX_start%pntr)) then if(X_MATRIX_start%number.eq.nmb) then deallocate(X_MATRIX_start%tre,X_MATRIX_start%trb,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if deallocate(X_MATRIX_start,STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if nullify(X_MATRIX_start) ierr=0 return end if else matrix_tester=>X_MATRIX_start if(matrix_tester%number.eq.nmb) then X_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=>X_MATRIX_start matrix_tester=>X_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 DELOC_X_MATRIX !!! !* !!! subroutine XACCESS_MATRIX(pmatrix,nmb,istat) implicit none type(X_MATRIX),pointer ::pmatrix integer,intent(out)::istat integer,intent(in) ::nmb type(X_MATRIX),pointer ::matrix_tester istat=-1 matrix_tester=>X_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 XACCESS_MATRIX !!! !* !!! subroutine NEW_X_ELEMENT(pmatrix,nmb_element,istat) implicit none type(X_MATRIX),pointer::pmatrix integer,intent(out)::nmb_element,istat type(X_ELEMENT),pointer::element_insert integer :: ierr istat = -1 if (.not.associated(pmatrix%X_ELEMENT_start)) then pmatrix%new=0 !status changed to blas_open_handle allocate(pmatrix%X_ELEMENT_start,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memalloc return end if pmatrix%X_ELEMENT_start%number=1 !will certainly changed nullify(pmatrix%X_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%X_ELEMENT_start element_insert%number=pmatrix%X_ELEMENT_start%number+1 pmatrix%X_ELEMENT_start=> element_insert end if select case(pmatrix%format) case('normal') pmatrix%X_ELEMENT_start%contents%pntin%value=0 pmatrix%X_ELEMENT_start%contents%pntin%row_ind=-1 pmatrix%X_ELEMENT_start%contents%pntin%col_ind=-1 nullify(pmatrix%X_ELEMENT_start%contents%blin%value) nullify(pmatrix%X_ELEMENT_start%contents%vblin%value) case('block') nullify(pmatrix%X_ELEMENT_start%contents%blin%value) nullify(pmatrix%X_ELEMENT_start%contents%vblin%value) pmatrix%X_ELEMENT_start%contents%blin%row_block_ind=-1 pmatrix%X_ELEMENT_start%contents%blin%col_block_ind=-1 case('vblock') nullify(pmatrix%X_ELEMENT_start%contents%blin%value) nullify(pmatrix%X_ELEMENT_start%contents%vblin%value) pmatrix%X_ELEMENT_start%contents%vblin%row_vblock_ind=-1 pmatrix%X_ELEMENT_start%contents%vblin%col_vblock_ind=-1 case default istat = blas_error_param return end select nmb_element=pmatrix%X_ELEMENT_start%number istat=0 end subroutine NEW_X_ELEMENT !!! !* !!! subroutine DELOC_X_ELEMENT (nmb_element,pmatrix,istat) implicit none integer ,intent(in)::nmb_element type(X_MATRIX),pointer::pmatrix integer ,intent(out)::istat type(X_ELEMENT),pointer ::element_tester integer::ierr istat=-1 if(.not.associated( pmatrix%X_ELEMENT_start%pntr)) then if(pmatrix%X_ELEMENT_start%number.eq.nmb_element) then if(associated(pmatrix%X_ELEMENT_start%contents%vblin%value))& then deallocate(pmatrix%X_ELEMENT_start%contents%vblin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if(associated(pmatrix%X_ELEMENT_start%contents%blin%value))& then deallocate(pmatrix%X_ELEMENT_start%contents%blin%value,& STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if if (associated(pmatrix%X_ELEMENT_start)) then deallocate(pmatrix%X_ELEMENT_start,STAT=ierr) if (ierr.ne.0) then istat = blas_error_memdeloc return end if end if nullify(pmatrix%X_ELEMENT_start) end if istat = 0 return else element_tester=>pmatrix%X_ELEMENT_start if(element_tester%number.eq.nmb_element) then pmatrix%X_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%X_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 DELOC_X_ELEMENT !!! !* !!! subroutine XACCESS_ELEMENT(pelement,nmb_element,& pmatrix,istat) implicit none type(X_INELEMENT),pointer::pelement integer,intent(in) ::nmb_element type(X_MATRIX),pointer::pmatrix integer,intent(out)::istat type(X_ELEMENT),pointer ::element_tester istat=-1 element_tester=>pmatrix%X_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 XACCESS_ELEMENT !!! !* !!! subroutine X_ELEMENT_NUM (nmb_element,pmatrix,i,j,istat) implicit none integer,intent(out),target::nmb_element type(X_MATRIX),pointer::pmatrix integer ,intent(in)::i,j integer,intent(out)::istat type(X_ELEMENT),pointer ::element_tester logical:: finder istat = -1 select case(pmatrix%format) case('normal') element_tester=>pmatrix%X_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%X_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%X_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 X_ELEMENT_NUM !!! !* !!! subroutine X_DEALLOC(nmb,istat) implicit none integer,intent(in)::nmb integer,intent(out)::istat type(X_MATRIX),pointer::pmatrix type(X_ELEMENT),pointer ::element_tester,next_element istat = -1 call XACCESS_MATRIX(pmatrix,nmb,istat) if (istat.ne.0) return element_tester=>pmatrix%X_ELEMENT_start if(.not.associated(element_tester%pntr)) then call DELOC_X_ELEMENT(element_tester%number,& pmatrix,istat) if (istat.ne.0) return else next_element=>element_tester%pntr do while((associated(next_element))) call DELOC_X_ELEMENT(element_tester%number,& pmatrix,istat) if (istat.ne.0) return element_tester=>next_element next_element=>element_tester%pntr end do call DELOC_X_ELEMENT(element_tester%number,& pmatrix,istat) if (istat.ne.0) return end if call DELOC_X_MATRIX(nmb,istat) if (istat.ne.0) return istat = 0 return end subroutine X_DEALLOC SHAR_EOF fi # end of overwriting check if test -f 'INS_ROUTINER_source.F' then echo shar: will not over-write existing file "'INS_ROUTINER_source.F'" else cat << "SHAR_EOF" > 'INS_ROUTINER_source.F' subroutine XINS_entry (pmatrix,val,i,j,istat) implicit none type(X_MATRIX),pointer ::pmatrix DCOMPLEX ,intent(in) ::val integer ,intent(in) ::i,j integer, intent(out) :: istat type(X_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_X_ELEMENT(pmatrix,nmb_element,istat) if (istat.ne.0) return call X_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 DELOC_X_ELEMENT(nmb_element,pmatrix,istat) if (istat.ne.0) return end if end if end subroutine XINS_entry !!! !* !!! subroutine XINS_block(pmatrix,val,i,j,istat) implicit none type( X_MATRIX),pointer ::pmatrix DCOMPLEX ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind,ierr DCOMPLEX ,dimension(:,:),allocatable,target::vv type(X_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_X_ELEMENT(pmatrix,nmb_element,istat) if (istat.ne.0) return call X_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 DELOC_X_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 XINS_block !!! !* !!! subroutine XINS_bl_entr(pmatrix,val,i,j,istat) implicit none type(X_MATRIX),pointer ::pmatrix DCOMPLEX ,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat DCOMPLEX ,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=ZZERO vall(i-ii*pmatrix%DIM(5),j-jj*pmatrix%DIM(6))=val call XINS_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 XINS_bl_entr !!! !* !!! subroutine XINS_varblock(vpmatrix,val,i,j,istat) implicit none type(X_MATRIX),pointer ::vpmatrix DCOMPLEX ,dimension(:,:) ,target,intent(in)::val integer ,intent(in)::i,j integer,intent(out)::istat integer ::nmb_element,ind integer::ierr DCOMPLEX ,dimension(:,:),allocatable,target::vv type(X_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_X_ELEMENT (vpmatrix,nmb_element,istat) if (istat.ne.0) return call X_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 DELOC_X_ELEMENT(nmb_element,vpmatrix,istat) if (istat.ne.0) return end if end if istat = 0 return end subroutine XINS_varblock !!! !* !!! subroutine XINS_varbl_entr(vpmatrix,val,i,j,istat) implicit none type(X_MATRIX),pointer ::vpmatrix DCOMPLEX,intent(in)::val integer,intent(in)::i,j integer,intent(out)::istat DCOMPLEX,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=ZZERO vall(vall_ind1,vall_ind2)=val call XINS_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 XINS_varbl_entr !!! !* !!! subroutine XUSCR_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 DCOMPLEX, dimension(:),allocatable :: val integer :: size_val,val_ind,indx_ind,bindx_ind,ii,jj,i,j type(X_MATRIX),pointer::pmatrix type(X_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 X_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%X_ELEMENT_start%number+1),& bindx(pmatrix%X_ELEMENT_start%number),& STAT=ierr) if(ierr.ne.0) then istat = blas_error_memalloc return endif val=ZZERO ! 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 X_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 X_DEALLOC(a,istat) if (istat.ne.0) return ! CREATING MATRIX IN VBR FORMAT istat=-1 !needed to create copy of data call XUSCR_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 XUSCR_varend !!! !* !!! subroutine XUSCR_normend (a,prpty,istat) implicit none integer ,intent(inout)::a,istat integer,intent(inout)::prpty integer:: m,n,nnz integer, dimension(:),allocatable :: indx,jndx DCOMPLEX, dimension(:),allocatable :: val integer :: nmb_element,i,ierr type(X_MATRIX ),pointer::pmatrix type(X_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%X_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 X_DEALLOC(a,istat) if (istat.ne.0) return ! CREATING A MATRIX IN COO FORMAT istat=-1 !needed to create copy of data call XUSCR_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 XUSCR_normend !!! !* !!! subroutine XUSCR_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 DCOMPLEX , dimension(:),allocatable :: val integer :: nmb_block type(X_MATRIX),pointer::pmatrix type(X_INELEMENT),pointer::pelement istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return lb=pmatrix%DIM(5) bnnz=pmatrix%X_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 X_DEALLOC(a,istat) if (istat.ne.0) return ! CREATE A MATRIX IN BCO FORMAT istat=-1 !needed to create copy of data call XUSCR_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 XUSCR_blockend SHAR_EOF fi # end of overwriting check if test -f 'conv_tools_source.F' then echo shar: will not over-write existing file "'conv_tools_source.F'" else cat << "SHAR_EOF" > 'conv_tools_source.F' subroutine XB_UP_ORDER(VAL,lbxlb,BINDX) implicit none DCOMPLEX,pointer ,dimension(:)::VAL integer ,pointer, dimension(:)::BINDX integer ,dimension(:),allocatable :: tes DCOMPLEX,dimension(:,:),allocatable::P integer ,intent(in) ::lbxlb integer ::s,i,j,k allocate(tes(lbxlb)) do i=1,lbxlb tes(i)=i end do s=size(VAL) k=floor(real(s/lbxlb)) allocate(P(lbxlb,k)) do j=1,s i=floor(real((j-1)/lbxlb)) P(j-i*lbxlb,i+1)=VAL(j) end do P=P(tes,BINDX) do j=1,s i=floor(real((j-1)/lbxlb)) VAL(j)=P(j-i*lbxlb,i+1) end do deallocate(tes,P) end subroutine XB_UP_ORDER function XA_ROW_COL(VAL,INDX,JNDX,i,j) DCOMPLEX,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::i,j integer::k logical::finder DCOMPLEX::XA_ROW_COL finder=.false. k=1 do while((k.le.size(VAL)).and.(.not.finder)) if(INDX(k).eq.i.and.JNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then XA_ROW_COL =VAL(k) else XA_ROW_COL =0 end if end function XA_ROW_COL subroutine XDETECT_DIAG(VAL,INDX,JNDX,ind,LDA,test) implicit none DCOMPLEX,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX,JNDX integer,intent(in)::ind,LDA integer,intent(inout)::test logical::finder DCOMPLEX::val_val integer ::k test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.LDA).and.(.not.finder)) val_val=XA_ROW_COL(VAL,INDX,JNDX,k,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k,k+ind) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.LDA).and.(.not.finder)) val_val=A_row_col(VAL,INDX,JNDX,k-ind,k) if(val_val.ne.0) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine XDETECT_DIAG function XAB_ROW_COL (VAL,BINDX,BJNDX,i,j,sub_ind,lb) DCOMPLEX,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::i,j,sub_ind,lb integer::k,dummy logical::finder DCOMPLEX:: XAB_ROW_COL dummy=lb*lb finder=.false. k=1 do while((k.le.size(BINDX)).and.(.not.finder)) if(BINDX(k).eq.i.and.BJNDX(k).eq.j) then finder=.true. else k=k+1 end if end do if(finder) then XAB_ROW_COL=VAL(dummy*(k-1)+sub_ind) else XAB_ROW_COL=0. end if end function XAB_ROW_COL subroutine XDETECT_BDIAG (VAL,BINDX,BJNDX,ind,BLDA,test,lb) implicit none DCOMPLEX,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX,BJNDX integer,intent(in)::ind,BLDA,lb integer,intent(inout)::test logical::finder,sub_finder DCOMPLEX::val_val integer ::k,sub_ind,dummy dummy=lb*lb test=0 if(ind.eq.0) then ! main diag test=0 finder=.false. k=1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if elseif(ind.lt.0)then ! low diag test=0 finder=.false. k=-ind+1 !do while((k.le.BLDA+ind).and.(.not.finder)) do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k,k+ind,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if else ! high diag test=0 finder=.false. k=ind+1 do while((k.le.BLDA).and.(.not.finder)) sub_ind=1 sub_finder=.false. do while((sub_ind.le.dummy).and.(.not.sub_finder)) val_val=Ab_row_col(VAL,BINDX,BJNDX,k-ind,k,sub_ind,lb) if(val_val.ne.0) then sub_finder=.true. else sub_ind= sub_ind+1 end if end do if(sub_finder) then finder=.true. else k=k+1 end if end do if(finder) then test=1 end if end if end subroutine XDETECT_BDIAG subroutine XPRE_COO2DIA (m,n,VAL,INDX,JNDX,LDA,NDIAG) implicit none DCOMPLEX ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,dimension(:),allocatable::IDIAG DCOMPLEX ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::m,n integer,intent(inout)::LDA,NDIAG integer :: i,test,ind,j,k,IDIAG_ind integer :: VAL_ind,VAL_DIA_size intrinsic min LDA=min(m,n) test=0 VAL_ind=0 IDIAG_ind=0 NDIAG=0 ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then NDIAG = NDIAG+1 end if do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then NDIAG=NDIAG+1 end if end do VAL_DIA_size=NDIAG*LDA allocate(IDIAG(NDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_diag(VAL,INDX,JNDX,ind,LDA,test) if(test.eq.1) then do i=1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,i,i) end do IDIAG(IDIAG_ind+1)=0 IDIAG_ind=IDIAG_ind+1 end if !**********low diag *********** do i=1,m-1 call detect_diag(VAL,INDX,JNDX,-i,LDA,test) if(test.eq.1) then do k=1,i VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do do k=i+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k-i) end do IDIAG(IDIAG_ind+1)=-i IDIAG_ind=IDIAG_ind+1 end if end do !*********** high diag ******* do j=1,n-1 call detect_diag(VAL,INDX,JNDX,j,LDA,test) if(test.eq.1) then do k=1,LDA-j VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=A_row_col(VAL,INDX,JNDX,k,k+j) end do do k=LDA-j+1,LDA VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do IDIAG(IDIAG_ind+1)=j IDIAG_ind=IDIAG_ind+1 end if end do deallocate(VAL,INDX) allocate(VAL(VAL_DIA_size),INDX(NDIAG)) VAL=VAL_DIA INDX=IDIAG deallocate(VAL_DIA) deallocate(IDIAG) end subroutine XPRE_COO2DIA subroutine XPRE_DIA2COO(VAL_DIA,IDIAG,IA2,LDA,NNZ) implicit none DCOMPLEX,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) :: IDIAG,IA2 integer,intent(in)::LDA,NNZ DCOMPLEX ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::INDX,JNDX integer:: VAL_size,i,k integer::VAL_ind,IND_ind,VAL_DIA_ind VAL_size =NNZ allocate(VAL( VAL_size),INDX( VAL_size),JNDX( VAL_size)) VAL=0. INDX=0. JNDX=0. VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(IDIAG) if(IDIAG(i).lt.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k+IDIAG(i) end if end do elseif(IDIAG(i).eq.0) then do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA( VAL_DIA_ind) INDX(IND_ind)=k JNDX(IND_ind)=k end if end do else do k=1,LDA VAL_DIA_ind= VAL_DIA_ind+1 if(VAL_DIA( VAL_DIA_ind).ne.0) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 VAL(VAL_ind)=VAL_DIA(VAL_DIA_ind ) JNDX(IND_ind)=IDIAG(i)+k INDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,IDIAG,IA2) allocate(VAL_DIA( VAL_size),IDIAG( VAL_size),IA2( VAL_size)) VAL_DIA=VAL IDIAG=INDX IA2=JNDX deallocate(VAL,INDX,JNDX) end subroutine XPRE_DIA2COO subroutine XPRE_BCO2BDI(mb,kb,lb,VAL,BINDX,BJNDX,BLDA,BNDIAG) implicit none DCOMPLEX ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,dimension(:),allocatable::BIDIAG DCOMPLEX ,dimension(:),allocatable::VAL_DIA integer ,intent(in)::mb,kb,lb integer,intent(inout)::BLDA,BNDIAG integer :: i,test,ind,j,k,BIDIAG_ind,VAL_ind integer ::VAL_DIA_size,dummy,sub_ind intrinsic min BLDA=min(mb,kb) dummy=lb*lb test=0 VAL_ind=0 BIDIAG_ind=0 BNDIAG=0 ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then BNDIAG = BNDIAG+1 end if do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then BNDIAG=BNDIAG+1 end if end do VAL_DIA_size=BNDIAG*BLDA*dummy allocate(BIDIAG(BNDIAG)) allocate(VAL_DIA(VAL_DIA_size)) !********* main diag ************ ind=0 call detect_bdiag(VAL,BINDX,BJNDX,ind,BLDA,test,lb) if(test.eq.1) then do i=1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,i,i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=0 BIDIAG_ind=BIDIAG_ind+1 end if !**********low diag *********** do i=1,mb-1 call detect_bdiag(VAL,BINDX,BJNDX,-i,BLDA,test,lb) if(test.eq.1) then do k=1,i do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do do k=i+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k-i,sub_ind,lb) end do end do BIDIAG(BIDIAG_ind+1)=-i BIDIAG_ind=BIDIAG_ind+1 end if end do !*********** high diag ******* do j=1,kb-1 call detect_bdiag(VAL,BINDX,BJNDX,j,BLDA,test,lb) if(test.eq.1) then do k=1,BLDA-j do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=Ab_row_col(VAL,BINDX,BJNDX,k,k+j,sub_ind,lb) end do end do do k=BLDA-j+1,BLDA do sub_ind=1,dummy VAL_ind=VAL_ind+1 VAL_DIA(VAL_ind)=0 end do end do BIDIAG(BIDIAG_ind+1)=j BIDIAG_ind=BIDIAG_ind+1 end if end do deallocate(VAL,BINDX) allocate(VAL(VAL_DIA_size),BINDX(BNDIAG)) VAL=VAL_DIA BINDX=BIDIAG deallocate(VAL_DIA) deallocate(BIDIAG) end subroutine XPRE_BCO2BDI subroutine XPRE_BDI2BCO(VAL_DIA,BIDIAG,IA2,BLDA,BNNZ,lb) implicit none DCOMPLEX,pointer,dimension(:) ::VAL_DIA integer ,pointer,dimension(:) ::BIDIAG,IA2 integer,intent(in)::BLDA,lb integer,intent(out)::BNNZ integer ,dimension(:),allocatable::VAL integer,dimension(:),allocatable ::BINDX,BJNDX DCOMPLEX::val_val integer:: VAL_size,i,k,VAL_ind,IND_ind integer::VAL_DIA_ind,dummy,sub_ind,NB_BLOCKS,dummy2 logical ::sub_finder intrinsic floor dummy=lb*lb NB_BLOCKS=floor(real(size(VAL_DIA)/dummy)) BNNZ=0 do VAL_DIA_ind=1,NB_BLOCKS sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then BNNZ=BNNZ+1 end if end do VAL_size =BNNZ allocate(VAL(dummy*VAL_size),BINDX(VAL_size)) allocate(BJNDX(VAL_size)) VAL=0. BINDX=0 BJNDX=0 VAL_ind=0 IND_ind=0 VAL_DIA_ind=0 do i=1,size(BIDIAG) if(BIDIAG(i).lt.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k+BIDIAG(i) end if end do elseif(BIDIAG(i).eq.0) then do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BINDX(IND_ind)=k BJNDX(IND_ind)=k end if end do else do k=1,BLDA VAL_DIA_ind= VAL_DIA_ind+1 sub_finder=.false. do sub_ind =1,dummy val_val=VAL_DIA(dummy*(VAL_DIA_ind-1)+sub_ind) if(val_val.ne.0) then sub_finder=.true. end if if(sub_finder) exit end do if(sub_finder) then IND_ind=IND_ind+1 VAL_ind=VAL_ind+1 do sub_ind=1,dummy dummy2=dummy*(VAL_ind-1)+sub_ind VAL(dummy2)=VAL_DIA(dummy2) end do BJNDX(IND_ind)=BIDIAG(i)+k BINDX(IND_ind)=k end if end do end if end do deallocate(VAL_DIA,BIDIAG,IA2) allocate(VAL_DIA(dummy*VAL_size),BIDIAG(VAL_size)) allocate(IA2(VAL_size)) VAL_DIA=VAL BIDIAG=BINDX IA2=BJNDX deallocate(VAL,BINDX,BJNDX) end subroutine XPRE_BDI2BCO subroutine XPRE_COO2CSR(VAL,INDX,JNDX,M,PNTRB,PNTRE) implicit none DCOMPLEX ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::M integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(INDX) allocate(DV(M)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,M DV(i)=counter(INDX,i) end do call PNTR(PNTRB,PNTRE,M,INDX) call up_order(INDX,ORD_RES) INDX=JNDX VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine XPRE_COO2CSR subroutine XPRE_COO2CSC(VAL,INDX,JNDX,K,PNTRB,PNTRE) implicit none DCOMPLEX ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: INDX integer,pointer,dimension(:)::JNDX integer,pointer,dimension(:)::PNTRB,PNTRE integer ,intent(in)::K integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s s=size(JNDX) allocate(DV(K)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,K DV(i)=counter(JNDX,i) end do allocate(DV(K+1)) call PNTR(PNTRB,PNTRE,K,JNDX) call up_order(JNDX,ORD_RES) VAL=VAL(ORD_RES) INDX=INDX(ORD_RES) call final_order(INDX,FNL_RES,DV) VAL=VAL(FNL_RES) INDX=INDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine XPRE_COO2CSC subroutine XPRE_BCO2BSR(VAL,BINDX,BJNDX,MB,LB,BPNTRB,BPNTRE) implicit none DCOMPLEX ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::MB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BINDX) dummy=LB*LB allocate(DV(MB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,MB DV(i)=counter(BINDX,i) end do call PNTR(BPNTRB,BPNTRE,MB,BINDX) call up_order(BINDX,ORD_RES) BINDX=BJNDX call XB_UP_ORDER(VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call XB_UP_ORDER(VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine XPRE_BCO2BSR subroutine XPRE_BCO2BSC(VAL,BINDX,BJNDX,KB,LB,BPNTRB,BPNTRE) implicit none DCOMPLEX ,pointer,dimension(:)::VAL integer ,pointer,dimension(:):: BINDX integer,pointer,dimension(:)::BJNDX integer,pointer,dimension(:)::BPNTRB,BPNTRE integer ,intent(in)::KB,LB integer,pointer,dimension(:)::DV,ORD_RES,FNL_RES integer :: i,s,dummy s=size(BJNDX) dummy=LB*LB allocate(DV(KB)) allocate(ORD_RES(s)) allocate(FNL_RES(s)) do i=1,KB DV(i)=counter(BJNDX,i) end do DV(KB+1)=counter(BJNDX,-1) call PNTR(BPNTRB,BPNTRE,KB,BJNDX) call up_order(BJNDX,ORD_RES) call XB_UP_ORDER(VAL,dummy,ORD_RES) BINDX=BINDX(ORD_RES) call final_order(BINDX,FNL_RES,DV) call XB_UP_ORDER(VAL,dummy,FNL_RES) BINDX=BINDX(FNL_RES) deallocate(DV) deallocate(ORD_RES) deallocate(FNL_RES) end subroutine XPRE_BCO2BSC SHAR_EOF fi # end of overwriting check if test -f 'dense_source.F' then echo shar: will not over-write existing file "'dense_source.F'" else cat << "SHAR_EOF" > 'dense_source.F' subroutine XBLOCK_MULT(A,x,n,y,m,store,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A,x DCOMPLEX, dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call XBLOCK_R_MULT(A,x,n,y,m,ierr) else call XBLOCK_L_MULT(A,x,n,y,m,ierr) end if end subroutine XBLOCK_MULT ! *** subroutine XBLOCK_Z_MULT(A,x,n,y,m,store,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A,x DCOMPLEX, dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call XBLOCK_R_MULT(A,CONJUG(x),n,y,m,ierr) else call XBLOCK_L_MULT(A,CONJUG(x),n,y,m,ierr) end if y=CONJUG(y) end subroutine XBLOCK_Z_MULT ! *** subroutine XBLOCK_T_MULT(A,x,n,y,m,store,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A,x DCOMPLEX, dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call XBLOCK_L_MULT(A,x,n,y,m,ierr) else call XBLOCK_R_MULT(A,x,n,y,m,ierr) end if end subroutine XBLOCK_T_MULT ! *** subroutine XBLOCK_H_MULT(A,x,n,y,m,store,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A,x DCOMPLEX, dimension(:), intent(inout) :: y integer, intent(in) :: m,n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call XBLOCK_L_MULT(A,CONJUG(x),n,y,m,ierr) else call XBLOCK_R_MULT(A,CONJUG(x),n,y,m,ierr) end if y=CONJUG(y) end subroutine XBLOCK_H_MULT ! *** subroutine XINV_LL(A,x,n,store,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call XINV_R_LL(A,x,n,ierr) else call XINV_L_RU(A,x,n,ierr) end if end subroutine XINV_LL ! *** subroutine XINV_T_LL(A,x,n,store,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call XINV_L_LL(A,x,n,ierr) else call XINV_R_RU(A,x,n,ierr) end if end subroutine XINV_T_LL ! *** subroutine XINV_RU(A,x,n,store,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call XINV_R_RU(A,x,n,ierr) else call XINV_L_LL(A,x,n,ierr) end if end subroutine XINV_RU ! *** subroutine XINV_T_RU(A,x,n,store,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(in) :: n character, intent(in) :: store integer, intent(out) :: ierr if (store.eq.'C') then call XINV_L_RU(A,x,n,ierr) else call XINV_R_LL(A,x,n,ierr) end if end subroutine XINV_T_RU ! *** ! *** ! *** subroutine XBLOCK_R_MULT(A,x,n,y,m,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A,x DCOMPLEX, dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(size(y).ne.m).or.(n*m.ne.size(A))) then return end if do j=1,n y = y + A((j-1)*m+1:j*m) * x(j) end do ierr = 0 end subroutine XBLOCK_R_MULT ! *** subroutine XBLOCK_L_MULT(A,x,m,y,n,ierr) implicit none intrinsic dot_product DCOMPLEX, dimension(:), intent(in) :: A,x DCOMPLEX, dimension(:), intent(inout) :: y integer, intent(in) :: m,n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.m).or.(size(y).ne.n).or.(n*m.ne.size(A))) then return end if do j=1,n y(j) = y(j) + dot_product(A((j-1)*m+1:j*m),x) end do ierr = 0 end subroutine XBLOCK_L_MULT ! *** subroutine XINV_R_LL(A,x,n,ierr) !left_lower, stored column-wise implicit none DCOMPLEX, dimension(:), intent(in) :: A DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(j+1:n) = x(j+1:n) - x(j) * a((j-1)*n+j+1:j*n) end do ierr = 0 end subroutine XINV_R_LL ! *** subroutine XINV_L_LL(A,x,n,ierr) !left_lower, stored row-wise implicit none intrinsic dot_product DCOMPLEX, dimension(:), intent(in) :: A DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 x(j) = x(j) - dot_product(a((j-1)*n+j+1:j*n),x(j+1:n)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine XINV_L_LL ! *** subroutine XINV_R_RU(A,x,n,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = n,1,-1 if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if x(1:j-1) = x(1:j-1) - x(j) * a((j-1)*n+1:(j-1)*n+j-1) end do ierr = 0 end subroutine XINV_R_RU ! *** subroutine XINV_L_RU(A,x,n,ierr) implicit none DCOMPLEX, dimension(:), intent(in) :: A DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(in) :: n integer, intent(out) :: ierr integer :: j ierr = -1 if((size(x).ne.n).or.(n*n.ne.size(A))) then return end if do j = 1,n x(j) = x(j) - dot_product(a((j-1)*n+1:(j-1)*n+j-1),x(1:j-1)) if (a((j-1)*n+j).ne.0) then x(j) = x(j)/a((j-1)*n+j) else ierr=blas_error_singtria return end if end do ierr = 0 end subroutine XINV_L_RU SHAR_EOF fi # end of overwriting check if test -f 'info_source.F' then echo shar: will not over-write existing file "'info_source.F'" else cat << "SHAR_EOF" > 'info_source.F' call accessdata(XSP_DATA,nmb,ierr) if (ierr.ne.0) then write(*,*) '***********************************' write(*,*) 'No data for no. ',nmb,' available !' write(*,*) '***********************************' return end if write(*,*) '***********************************' write(*,*) 'Matrix no. ', nmb write(*,*) 'number of rows : ', XSP_DATA%M write(*,*) 'number of columns : ', XSP_DATA%K write(*,*) 'Storage : ', XSP_DATA%FIDA write(*,*) 'A : ', XSP_DATA%A write(*,*) 'IA1 : ', XSP_DATA%IA1 write(*,*) 'IA2 : ', XSP_DATA%IA2 write(*,*) '***********************************' call get_descra(XSP_DATA%DESCRA,'a',part,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix part accessed : ',part end if call get_descra(XSP_DATA%DESCRA,'b',style,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Index style : ',style end if call get_descra(XSP_DATA%DESCRA,'d',diag,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Unity-diagonal : ',diag end if call get_descra(XSP_DATA%DESCRA,'f',store,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block-internal storage : ',store end if call get_descra(XSP_DATA%DESCRA,'t',type,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix type : ',type end if call get_infoa(XSP_DATA%INFOA,'b',base,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Indices start at : ',base end if call get_infoa(XSP_DATA%INFOA,'c',copy,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Matrix is copy of original data : ',copy end if call get_infoa(XSP_DATA%INFOA,'n',nnz,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'number of non-zero(-block)s : ',nnz end if call get_infoa(XSP_DATA%INFOA,'d',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) row dim of block : ',rowdim end if call get_infoa(XSP_DATA%INFOA,'e',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) '(Multi-dim arrays) col dim of block : ',coldim end if call get_infoa(XSP_DATA%INFOA,'f',rowdim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : row-dim in blocks : ',rowdim end if call get_infoa(XSP_DATA%INFOA,'g',coldim,ierr) if (ierr.ne.0) then write(*,*) 'No information avail. for that argument' return else write(*,*) 'Block structure : col-dim in blocks : ',coldim end if write(*,*) '***********************************' SHAR_EOF fi # end of overwriting check if test -f 'link_source.F' then echo shar: will not over-write existing file "'link_source.F'" else cat << "SHAR_EOF" > 'link_source.F' ! *** Allocate new memory subroutine NEW_XSP(nmb,ierr) integer, intent(out) :: nmb,ierr type(XSP_LINKNODE), pointer :: help if(.not.XSP_INIT) then nullify(XSP_FIRST) XSP_INIT = .TRUE. endif if (.not.associated(XSP_FIRST)) then allocate(XSP_FIRST,STAT=ierr) XSP_FIRST%number = XSP_MATRIX nullify(XSP_FIRST%pntr) XSP_LAST => XSP_FIRST else allocate(help,STAT=ierr) XSP_LAST%pntr => help help%number = XSP_LAST%number + no_of_types nullify(help%pntr) XSP_LAST => help end if nullify(XSP_LAST%contents%A,XSP_LAST%contents%IA1,& XSP_LAST%contents%IA2,XSP_LAST%contents%PB,& XSP_LAST%contents%PE,XSP_LAST%contents%BP1,& XSP_LAST%contents%BP2) XSP_LAST%contents%FIDA ='' XSP_LAST%contents%DESCRA ='' XSP_LAST%contents%INFOA = 0 nmb = XSP_LAST%number end subroutine NEW_XSP ! *** Deallocate unused memory subroutine DEL_XSP(nmb,ierr) type(XSP_LINKNODE), pointer :: help,help2 integer, intent(in) :: nmb integer, intent(out) :: ierr ierr = -1 if (XSP_FIRST%number.eq.nmb) then ierr=0 if (associated(XSP_FIRST,XSP_LAST)) then deallocate(XSP_FIRST) nullify(XSP_FIRST,XSP_LAST) else help2 => XSP_FIRST%pntr deallocate(XSP_FIRST) XSP_FIRST => help2 end if else help => XSP_FIRST do while((ierr.eq.-1).and.(associated(help%pntr%pntr))) if (help%pntr%number.eq.nmb) then help2 => help%pntr help%pntr => help%pntr%pntr deallocate(help2) ierr = 0 else help => help%pntr end if end do if((ierr.eq.-1).and.(help%pntr%number.eq.nmb)) then ierr = 0 help2 => help%pntr XSP_LAST => help nullify(XSP_LAST%pntr) deallocate(help2) end if end if end subroutine DEL_XSP ! *** access contents for given number nmb subroutine ACCESSDATA_XSP(dspmtx,nmb,ierr) type(XSPMAT), pointer :: dspmtx integer, intent(in) :: nmb integer, intent(out) :: ierr type(XSP_LINKNODE), pointer :: XSP_HANDLE ierr = -1 XSP_HANDLE => XSP_FIRST do while((XSP_HANDLE%number.ne.nmb).and.& (associated(XSP_HANDLE%pntr))) XSP_HANDLE => XSP_HANDLE%pntr end do if (XSP_HANDLE%number.eq.nmb) then ierr = 0 dspmtx => XSP_HANDLE%contents else nullify(dspmtx) end if end subroutine ACCESSDATA_XSP SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bco_source.F' then echo shar: will not over-write existing file "'lmbv_bco_source.F'" else cat << "SHAR_EOF" > 'lmbv_bco_source.F' subroutine XLMBV_BCO(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr=blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = ZZERO nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_Z_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,& y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine XLMBV_BCO SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bdi_source.F' then echo shar: will not over-write existing file "'lmbv_bdi_source.F'" else cat << "SHAR_EOF" > 'lmbv_bdi_source.F' subroutine XLMBV_BDI(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = ZZERO nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine XLMBV_BDI SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bsc_source.F' then echo shar: will not over-write existing file "'lmbv_bsc_source.F'" else cat << "SHAR_EOF" > 'lmbv_bsc_source.F' subroutine XLMBV_BSC(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = ZZERO nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XLMBV_BSC SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bsr_source.F' then echo shar: will not over-write existing file "'lmbv_bsr_source.F'" else cat << "SHAR_EOF" > 'lmbv_bsr_source.F' subroutine XLMBV_BSR(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.m).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = ZZERO nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_Z_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XLMBV_BSR SHAR_EOF fi # end of overwriting check if test -f 'lmbv_coo_source.F' then echo shar: will not over-write existing file "'lmbv_coo_source.F'" else cat << "SHAR_EOF" > 'lmbv_coo_source.F' subroutine XLMBV_COO(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,i,ofs character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + mat%A(i) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + CONJUG(mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i)+ofs) = y(mat%IA1(i)+ofs) & + CONJUG(mat%A(i)) * x(mat%IA2(i)+ofs) y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz y(mat%IA2(i)+ofs) = y(mat%IA2(i)+ofs) & + mat%A(i) * x(mat%IA1(i)+ofs) end do ierr = 0 end if end subroutine XLMBV_COO SHAR_EOF fi # end of overwriting check if test -f 'lmbv_csc_source.F' then echo shar: will not over-write existing file "'lmbv_csc_source.F'" else cat << "SHAR_EOF" > 'lmbv_csc_source.F' subroutine XLMBV_CSC(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + CONJUG(mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr+ofs)+ofs)= y(mat%IA1(pntr+ofs)+ofs) & + CONJUG(mat%A(pntr + ofs)) * x(j) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(j) = y(j) + & mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XLMBV_CSC SHAR_EOF fi # end of overwriting check if test -f 'lmbv_csr_source.F' then echo shar: will not over-write existing file "'lmbv_csr_source.F'" else cat << "SHAR_EOF" > 'lmbv_csr_source.F' subroutine XLMBV_CSR(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'L') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + CONJUG(mat%A(pntr + ofs)) & * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) + CONJUG(mat%A(pntr + ofs))& * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XLMBV_CSR SHAR_EOF fi # end of overwriting check if test -f 'lmbv_dia_source.F' then echo shar: will not over-write existing file "'lmbv_dia_source.F'" else cat << "SHAR_EOF" > 'lmbv_dia_source.F' subroutine XLMBV_DIA(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + mat%A(start_a+j) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + CONJUG(mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + CONJUG(mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,-mat%IA1(i)) start_y = max(0,mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine XLMBV_DIA SHAR_EOF fi # end of overwriting check if test -f 'lmbv_vbr_source.F' then echo shar: will not over-write existing file "'lmbv_vbr_source.F'" else cat << "SHAR_EOF" > 'lmbv_vbr_source.F' subroutine XLMBV_VBR(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.m)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'L') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_Z_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XLMBV_VBR SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bco_source.F' then echo shar: will not over-write existing file "'lsbv_bco_source.F'" else cat << "SHAR_EOF" > 'lsbv_bco_source.F' subroutine XLSBV_BCO(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb,nnz integer :: mm,nn,nn_sq character :: diag,part,store type(capsule), pointer :: dummy DCOMPLEX, allocatable, dimension(:) :: y !extra stor.! ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,& (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = 1,nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_T_mult_vec(& mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1),& x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine XLSBV_BCO SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bdi_source.F' then echo shar: will not over-write existing file "'lsbv_bdi_source.F'" else cat << "SHAR_EOF" > 'lsbv_bdi_source.F' subroutine XLSBV_BDI(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO if (part.eq.'L') then do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((-mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).lt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.i).and.& (mat%IA1(j).gt.0)) then call block_T_mult_vec(& mat%A((blda*(j-1)-mat%IA1(j)+i-1)*nn_sq+1:& (blda*(j-1)-mat%IA1(j)+i)*nn_sq),& x((i-mat%IA1(j)-1)*nn+1:(i-mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_T_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine XLSBV_BDI SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bsc_source.F' then echo shar: will not over-write existing file "'lsbv_bsc_source.F'" else cat << "SHAR_EOF" > 'lsbv_bsc_source.F' subroutine XLSBV_BSC(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO if (part.eq.'L') then do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while(pntr.lt.mat%pe(j)) if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr else call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((j-1)*nn+1:j*nn) = x((j-1)*nn+1:j*nn) - y end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine XLSBV_BSC SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bsr_source.F' then echo shar: will not over-write existing file "'lsbv_bsr_source.F'" else cat << "SHAR_EOF" > 'lsbv_bsr_source.F' subroutine XLSBV_BSR(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_T_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine XLSBV_BSR SHAR_EOF fi # end of overwriting check if test -f 'lsbv_coo_source.F' then echo shar: will not over-write existing file "'lsbv_coo_source.F'" else cat << "SHAR_EOF" > 'lsbv_coo_source.F' subroutine XLSBV_COO(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA2(i)+ofs,mat%IA1(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne.ZZERO) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne.ZZERO) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine XLSBV_COO SHAR_EOF fi # end of overwriting check if test -f 'lsbv_csc_source.F' then echo shar: will not over-write existing file "'lsbv_csc_source.F'" else cat << "SHAR_EOF" > 'lsbv_csc_source.F' subroutine XLSBV_CSC(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part DCOMPLEX :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = ZZERO pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq.ZZERO) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do else de = ZZERO pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.eq.i) then de = mat%A(pntr + ofs) else x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) end if pntr = pntr + 1 end do if(de.eq.ZZERO) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine XLSBV_CSC SHAR_EOF fi # end of overwriting check if test -f 'lsbv_csr_source.F' then echo shar: will not over-write existing file "'lsbv_csr_source.F'" else cat << "SHAR_EOF" > 'lsbv_csr_source.F' subroutine XLSBV_CSR(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part DCOMPLEX :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq.ZZERO) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq.ZZERO) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine XLSBV_CSR SHAR_EOF fi # end of overwriting check if test -f 'lsbv_dia_source.F' then echo shar: will not over-write existing file "'lsbv_dia_source.F'" else cat << "SHAR_EOF" > 'lsbv_dia_source.F' subroutine XLSBV_DIA(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part DCOMPLEX :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do else de = ZZERO do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((-mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).lt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j))*x(i-mat%IA1(j)) end if end do if (de.ne.ZZERO) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do else de = ZZERO do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.i).and.(mat%IA1(j).gt.0)) & then x(i) = x(i)-mat%A(lda*(j-1)+i-mat%IA1(j)) *x(i-mat%IA1(j)) end if end do if (de.ne.ZZERO) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine XLSBV_DIA SHAR_EOF fi # end of overwriting check if test -f 'lsbv_vbr_source.F' then echo shar: will not over-write existing file "'lsbv_vbr_source.F'" else cat << "SHAR_EOF" > 'lsbv_vbr_source.F' subroutine XLSBV_VBR(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do j = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_left_lower(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = 1,mb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and.& (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then dd = pntr else ierr = blas_error_singtria return end if if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call invert_T_right_upper(& mat%A(start_a:end_a),x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then start_x = mat%bp1(j) + ofs end_x = mat%bp1(j+1) + ofs -1 len_x = end_x - start_x + 1 start_y = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_y = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_T_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine XLSBV_VBR SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bco_source.F' then echo shar: will not over-write existing file "'rmbv_bco_source.F'" else cat << "SHAR_EOF" > 'rmbv_bco_source.F' subroutine XRMBV_BCO(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,bofs,i,mm,nn,nnz,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = ZZERO nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else if ((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).lt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) else if (mat%IA1(i).gt.mat%IA2(i)) then call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn, & y((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,store,ierr) end if end do end if ierr = 0 else !no symmetry do i = 1, nnz call block_mult_vec(mat%A((i-1)*nn_sq+1:i*nn_sq),& x((mat%IA2(i)+bofs)*nn+1:(mat%IA2(i)+bofs+1)*nn),nn,& y((mat%IA1(i)+bofs)*nn+1:(mat%IA1(i)+bofs+1)*nn),nn,store,ierr) end do ierr = 0 end if end subroutine XRMBV_BCO SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bdi_source.F' then echo shar: will not over-write existing file "'rmbv_bdi_source.F'" else cat << "SHAR_EOF" > 'rmbv_bdi_source.F' subroutine XRMBV_BDI(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j,mm,nn,nn_sq integer :: blda,nbdiag,start_a,end_a,start_x,start_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = ZZERO nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda j = 1 do while((start_a + j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_y+j-1)*nn+1:(start_y+j)*nn),& nn,y((start_x+j-1)*nn+1:(start_x+j)*nn),nn,store,ierr) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*blda end_a = i*blda j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,nbdiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.(mat%K/nn)-blda) then start_a = (i-1)*blda end_a = i*blda -mat%IA1(i)+(mat%K/nn)-blda else if (mat%IA1(i).lt.-(mat%M/nn)+blda) then start_a = (i-1)*blda -mat%IA1(i)-(mat%M/nn)+blda end_a = i*blda else start_a = (i-1)*blda end_a = i*blda end if j = 1 do while((start_a+j).le.end_a) call block_mult_vec(& mat%A((start_a+j-1)*nn_sq+1:(start_a+j)*nn_sq),& x((start_x+j-1)*nn+1:(start_x+j)*nn),& nn,y((start_y+j-1)*nn+1:(start_y+j)*nn),nn,store,ierr) j = j+1 end do end do ierr = 0 end if end subroutine XRMBV_BDI SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bsc_source.F' then echo shar: will not over-write existing file "'rmbv_bsc_source.F'" else cat << "SHAR_EOF" > 'rmbv_bsc_source.F' subroutine XRMBV_BSC(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,j,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = ZZERO nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((j-1)*nn+1:j*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do j = 1, nb pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XRMBV_BSC SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bsr_source.F' then echo shar: will not over-write existing file "'rmbv_bsr_source.F'" else cat << "SHAR_EOF" > 'rmbv_bsr_source.F' subroutine XRMBV_BSR(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,bofs,i,pntr,mm,nn,mb,nb,nn_sq character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.m).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if y = ZZERO nn_sq = nn*nn if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_T_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) call block_H_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),& nn,y((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+& bofs+1)*nn),nn,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y((i-1)*nn+1:i*nn),nn,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XRMBV_BSR SHAR_EOF fi # end of overwriting check if test -f 'rmbv_coo_source.F' then echo shar: will not over-write existing file "'rmbv_coo_source.F'" else cat << "SHAR_EOF" > 'rmbv_coo_source.F' subroutine XRMBV_COO(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,nnz,base,ofs,i character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + mat%A(i) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).lt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + CONJUG(mat%A(i)) * x(mat%IA1(i) + ofs) end if end do else do i = 1, nnz if (mat%IA1(i).eq.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) else if (mat%IA1(i).gt.mat%IA2(i)) then y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) y(mat%IA2(i) + ofs) = y(mat%IA2(i) + ofs) & + CONJUG(mat%A(i)) * x(mat%IA1(i) + ofs) end if end do end if ierr = 0 else do i = 1, nnz y(mat%IA1(i) + ofs) = y(mat%IA1(i) + ofs) & + mat%A(i) * x(mat%IA2(i) + ofs) end do ierr = 0 end if end subroutine XRMBV_COO SHAR_EOF fi # end of overwriting check if test -f 'rmbv_csc_source.F' then echo shar: will not over-write existing file "'rmbv_csc_source.F'" else cat << "SHAR_EOF" > 'rmbv_csc_source.F' subroutine XRMBV_CSC(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,j,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.gt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) y(j) = y(j) & +CONJUG(mat%A(pntr + ofs)) * x(mat%IA1(pntr + ofs)+ ofs) end if pntr = pntr + 1 end do end do else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(j.eq.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) else if (j.lt.mat%IA1(pntr + ofs) + ofs) then y(mat%IA1(pntr + ofs)+ofs) =y(mat%IA1(pntr+ofs)+ofs) & +mat%A(pntr + ofs) * x(j) y(j) = y(j) + CONJUG(mat%A(pntr+ofs)) & * x(mat%IA1(pntr + ofs) + ofs) end if pntr = pntr + 1 end do end do end if ierr = 0 else do j = 1, mat%K pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XRMBV_CSC SHAR_EOF fi # end of overwriting check if test -f 'rmbv_csr_source.F' then echo shar: will not over-write existing file "'rmbv_csr_source.F'" else cat << "SHAR_EOF" > 'rmbv_csr_source.F' subroutine XRMBV_CSR(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr + ofs) + ofs) = & y(mat%IA1(pntr + ofs ) + ofs) + mat%A(pntr + ofs) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + CONJUG(mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) if(i.eq.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) y(mat%IA1(pntr+ofs)+ofs)=y(mat%IA1(pntr+ofs)+ofs) & + CONJUG(mat%A(pntr + ofs)) * x(i) end if pntr = pntr + 1 end do end do end if ierr = 0 else do i = 1, mat%M pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) y(i) = y(i) & + mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs ) + ofs) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XRMBV_CSR SHAR_EOF fi # end of overwriting check if test -f 'rmbv_dia_source.F' then echo shar: will not over-write existing file "'rmbv_dia_source.F'" else cat << "SHAR_EOF" > 'rmbv_dia_source.F' subroutine XRMBV_DIA(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,i,j integer :: lda,ndiag,start_a,end_a,start_x,start_y character :: diag,type,part ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + mat%A(start_a+j) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) & then if (part.eq.'U') then do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.0) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda j = 1 do while((start_a + j).le.end_a) y(start_y +j) = y(start_y +j) & + mat%A(start_a+j) * x(start_x +j) y(start_x +j) = y(start_x +j) & + CONJUG(mat%A(start_a+j)) * x(start_y +j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do else !(part.eq.'L') do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).lt.0) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) y(start_x +j) = y(start_x+j) & + CONJUG(mat%A(start_a+j)) * x(start_y+j) j = j+1 end do else if (mat%IA1(i).eq.0) then start_a = (i-1)*lda end_a = i*lda j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do else cycle end if end do end if ierr = 0 else !no symmetry do i=1,ndiag start_x = max(0,mat%IA1(i)) start_y = max(0,-mat%IA1(i)) if (mat%IA1(i).gt.mat%K-lda) then start_a = (i-1)*lda end_a = i*lda -mat%IA1(i)+mat%K-lda else if (mat%IA1(i).lt.-mat%M+lda) then start_a = (i-1)*lda -mat%IA1(i)-mat%M+lda end_a = i*lda else start_a = (i-1)*lda end_a = i*lda end if j = 1 do while((start_a + j).le.end_a) y(start_y+j) = y(start_y+j) & + mat%A(start_a+j) * x(start_x+j) j = j+1 end do end do ierr = 0 end if end subroutine XRMBV_DIA SHAR_EOF fi # end of overwriting check if test -f 'rmbv_vbr_source.F' then echo shar: will not over-write existing file "'rmbv_vbr_source.F'" else cat << "SHAR_EOF" > 'rmbv_vbr_source.F' subroutine XRMBV_VBR(mat,x,y,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(out) :: y integer, intent(out) :: ierr integer :: m,n,base,ofs,i,pntr,mb,nb integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,type,part,store ierr = -1 m = size(y) n = size(x) if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.m).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if y = ZZERO start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (diag.eq.'U') then !process unstored diagonal if (m.eq.n) then y = x else ierr = blas_error_param return end if end if if ((type.eq.'S').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_T_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else if((type.eq.'H').and.(.not.(part.eq.'B')).and.(m.eq.n)) then if (part.eq.'U') then do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.lt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do else do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs)+ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 if(i.eq.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) else if (i.gt.mat%IA1(pntr + ofs) + ofs) then call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) call block_H_mult_vec(mat%A(start_a:end_a),& x(start_y:end_y),len_y,y(start_x:end_x),len_x,store,ierr) end if pntr = pntr + 1 end do end do end if ierr = 0 else !no symmetry do i = 1, mb pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1) + ofs - 1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) pntr = pntr + 1 end do end do ierr = 0 end if end subroutine XRMBV_VBR SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bco_source.F' then echo shar: will not over-write existing file "'rsbv_bco_source.F'" else cat << "SHAR_EOF" > 'rsbv_bco_source.F' subroutine XRSBV_BCO(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,ofs,base,nb,mb integer :: mm,nn,nnz,nn_sq character :: diag,part,store type(capsule), pointer :: dummy DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if if ((mat%FIDA.ne.'BCO').or.(mat%M.ne.n).or.(mat%K.ne.n).or. & (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO call setup_hash(nb,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs, & (i-1)*nn_sq+1,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, nb dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = nb,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr call block_mult_vec( & mat%A(dummy%val_pos:dummy%val_pos+nn_sq-1), & x((dummy%jndx-1)*nn+1:(dummy%jndx)*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A(hash(i)%val_pos:hash(i)%val_pos+nn_sq-1), & x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call remove_hash(ierr) end subroutine XRSBV_BCO SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bdi_source.F' then echo shar: will not over-write existing file "'rsbv_bdi_source.F'" else cat << "SHAR_EOF" > 'rsbv_bdi_source.F' subroutine XRSBV_BDI(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,mm,nn,blda,nbdiag,dd,nn_sq character :: diag,part,store DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',blda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nbdiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BDI').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn)) then ierr = blas_error_param return end if nn_sq = nn * nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO if (part.eq.'L') then do i=1,blda if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0))& then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_left_lower(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i=blda,1,-1 if (diag.eq.'U') then do j = 1,nbdiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do else dd = -1 do j = 1,nbdiag if (mat%IA1(j).eq.0) then dd = j else if((mat%IA1(j).lt.blda-i+1).and.& (mat%IA1(j).gt.0))then call block_mult_vec(& mat%A((blda*(j-1)+i-1)*nn_sq+1:(blda*(j-1)+i)*nn_sq),& x((i+mat%IA1(j)-1)*nn+1:(i+mat%IA1(j))*nn),nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn) = x((i-1)*nn+1:i*nn) - y end if end do if (dd.ne.-1) then call invert_right_upper(& mat%A((blda*(dd-1)+i-1)*nn_sq+1:(blda*(dd-1)+i)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) else ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine XRSBV_BDI SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bsc_source.F' then echo shar: will not over-write existing file "'rsbv_bsc_source.F'" else cat << "SHAR_EOF" > 'rsbv_bsc_source.F' subroutine XRSBV_BSC(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSC').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO if (part.eq.'L') then do j = 1,nb if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do j = nb,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y pntr = pntr + 1 end do else pntr = mat%pb(j) dd = -1 do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr+ofs)+ofs.ne.j)) pntr = pntr + 1 end do if (mat%IA1(pntr+ofs)+ofs.eq.j) then dd = pntr end if if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper( & mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) if(mat%IA1(pntr + ofs) + ofs.ne.j) then call block_mult_vec( & mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq), & x((j-1)*nn+1:j*nn),nn,y,nn,store,ierr) x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)=& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn)-y end if pntr = pntr + 1 end do end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine XRSBV_BSC SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bsr_source.F' then echo shar: will not over-write existing file "'rsbv_bsr_source.F'" else cat << "SHAR_EOF" > 'rsbv_bsr_source.F' subroutine XRSBV_BSR(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,bofs,mm,nn,mb,nb,dd,nn_sq character :: diag,part,store DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base bofs = -base call get_infoa(mat%INFOA,'d',mm,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',nn,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if ((mat%FIDA.ne.'BSR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (mm.ne.nn).or.(nb.ne.mb)) then ierr = blas_error_param return end if nn_sq = nn*nn allocate(y(nn),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_left_lower(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then call block_mult_vec(& mat%A((pntr + bofs)*nn_sq+1:(pntr + bofs +1)*nn_sq),& x((mat%IA1(pntr+ofs)+bofs)*nn+1:(mat%IA1(pntr+ofs)+bofs+1)*nn),& nn,y,nn,store,ierr) x((i-1)*nn+1:i*nn)= x((i-1)*nn+1:i*nn) - y else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else call invert_right_upper(& mat%A((dd + bofs)*nn_sq+1:(dd + bofs +1)*nn_sq),& x((i-1)*nn+1:i*nn),nn,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine XRSBV_BSR SHAR_EOF fi # end of overwriting check if test -f 'rsbv_coo_source.F' then echo shar: will not over-write existing file "'rsbv_coo_source.F'" else cat << "SHAR_EOF" > 'rsbv_coo_source.F' subroutine XRSBV_COO(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,nnz character :: diag,part type(capsule), pointer :: dummy ierr = -1 n = size(x) if ((mat%FIDA.ne.'COO').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'n',nnz,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call setup_hash(n,ierr) if (ierr.ne.0) then return end if do i = 1, nnz call new_capsule_main(mat%IA1(i)+ofs,mat%IA2(i)+ofs,i,ierr) if (ierr.ne.0) then return end if end do if (part.eq.'L') then do i = 1, n dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne.ZZERO) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 else do i = n,1,-1 dummy => hash(i) do while(associated(dummy%pntr)) dummy => dummy%pntr x(i) = x(i) - x(dummy%jndx) * mat%A(dummy%val_pos) end do if (diag.ne.'U') then if(hash(i)%jndx.eq.-1) then ierr = blas_error_singtria return else if (mat%A(hash(i)%val_pos).ne.ZZERO) then x(i) = x(i)/mat%A(hash(i)%val_pos) else ierr = blas_error_singtria return end if end if end if end do ierr = 0 end if call remove_hash(ierr) end subroutine XRSBV_COO SHAR_EOF fi # end of overwriting check if test -f 'rsbv_csc_source.F' then echo shar: will not over-write existing file "'rsbv_csc_source.F'" else cat << "SHAR_EOF" > 'rsbv_csc_source.F' subroutine XRSBV_CSC(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: j,n,base,ofs,pntr character :: diag,part DCOMPLEX :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSC').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do j = 1,n if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq.ZZERO) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 else do j = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * x(j) pntr = pntr + 1 end do else pntr = mat%pb(j) do while((pntr.lt.mat%pe(j)).and. & (mat%IA1(pntr + ofs) + ofs.ne.j)) pntr = pntr + 1 end do if(mat%IA1(pntr + ofs) + ofs.eq.j) then de = mat%A(pntr + ofs) else ierr = blas_error_singtria return end if if(de.eq.ZZERO) then ierr = blas_error_singtria return else x(j) = x(j)/de de = x(j) end if pntr = mat%pb(j) do while(pntr.lt.mat%pe(j)) x(mat%IA1(pntr + ofs) + ofs) = & x(mat%IA1(pntr + ofs ) + ofs) - mat%A(pntr + ofs) * de pntr = pntr + 1 end do x(j) = de end if end do ierr = 0 end if end subroutine XRSBV_CSC SHAR_EOF fi # end of overwriting check if test -f 'rsbv_csr_source.F' then echo shar: will not over-write existing file "'rsbv_csr_source.F'" else cat << "SHAR_EOF" > 'rsbv_csr_source.F' subroutine XRSBV_CSR(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,ofs,pntr character :: diag,part DCOMPLEX :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'CSR').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i = 1,n if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = ZZERO do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq.ZZERO) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 else do i = n,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) pntr = pntr + 1 end do else pntr = mat%pb(i) de = ZZERO do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then x(i) = x(i) & - mat%A(pntr + ofs) * x(mat%IA1(pntr + ofs) + ofs) else de = mat%A(pntr + ofs) end if pntr = pntr + 1 end do if(de.eq.ZZERO) then ierr = blas_error_singtria return else x(i) = x(i)/de end if end if end do ierr = 0 end if end subroutine XRSBV_CSR SHAR_EOF fi # end of overwriting check if test -f 'rsbv_dia_source.F' then echo shar: will not over-write existing file "'rsbv_dia_source.F'" else cat << "SHAR_EOF" > 'rsbv_dia_source.F' subroutine XRSBV_DIA(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,j,n,lda,ndiag character :: diag,part DCOMPLEX :: de ierr = -1 n = size(x) if ((mat%FIDA.ne.'DIA').or.(mat%M.ne.n).or.(mat%K.ne.n)) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'d',lda,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'e',ndiag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ierr = -1 if (part.eq.'L') then do i=1,n if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = ZZERO do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).gt.-i).and.(mat%IA1(j).lt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne.ZZERO) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 else do i=n,1,-1 if (diag.eq.'U') then do j = 1,ndiag if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do else de = ZZERO do j = 1,ndiag if (mat%IA1(j).eq.0) then de = mat%A(lda*(j-1) + i) else if((mat%IA1(j).lt.n-i+1).and.(mat%IA1(j).gt.0)) then x(i) = x(i)-mat%A(lda*(j-1)+i) * x(i+mat%IA1(j)) end if end do if (de.ne.ZZERO) then x(i) = x(i)/de else ierr = blas_error_singtria return end if end if end do ierr = 0 end if end subroutine XRSBV_DIA SHAR_EOF fi # end of overwriting check if test -f 'rsbv_vbr_source.F' then echo shar: will not over-write existing file "'rsbv_vbr_source.F'" else cat << "SHAR_EOF" > 'rsbv_vbr_source.F' subroutine XRSBV_VBR(mat,x,ierr) implicit none type(XSPMAT), pointer :: mat DCOMPLEX, dimension(:), intent(inout) :: x integer, intent(out) :: ierr integer :: i,n,base,pntr,ofs,mb,nb,dd integer :: start_a,end_a,start_x,end_x,len_x,start_y,end_y,len_y character :: diag,part,store DCOMPLEX, allocatable, dimension(:) :: y ierr = -1 n = size(x) allocate(y(size(x)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if y = ZZERO if ((mat%FIDA.ne.'VBR').or.(mat%M.ne.n).or.(mat%K.ne.n).or.& (size(mat%bp1).ne.size(mat%bp2)).or.& (maxval(abs(mat%bp1-mat%bp2)).ne.0)) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ofs = 1 - base call get_infoa(mat%INFOA,'f',mb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(mat%INFOA,'g',nb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'d',diag,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'f',store,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(mat%DESCRA,'a',part,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if ((part.ne.'U').and.(part.ne.'L')) then ierr = blas_error_param return end if ierr = -1 start_a = -1 end_a = -1 start_x = -1 end_x = -1 start_y = -1 end_y = -1 if (part.eq.'L') then do i = 1,mb if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_left_lower(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if else do i = mb,1,-1 if (diag.eq.'U') then pntr = mat%pb(i) do while(pntr.lt.mat%pe(i)) start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) pntr = pntr + 1 end do else pntr = mat%pb(i) dd = -1 do while(pntr.lt.mat%pe(i)) if(mat%IA1(pntr + ofs) + ofs.ne.i) then start_x = mat%bp2(mat%IA1(pntr+ofs)+ofs) + ofs end_x = mat%bp2(mat%IA1(pntr+ofs)+ofs+1)+ofs-1 len_x = end_x - start_x + 1 start_y = mat%bp1(i) + ofs end_y = mat%bp1(i+1) + ofs -1 len_y = end_y - start_y + 1 start_a = mat%IA2(pntr+ofs) + ofs end_a = mat%IA2(pntr+ofs+1) + ofs - 1 call block_mult_vec(mat%A(start_a:end_a),& x(start_x:end_x),len_x,y(start_y:end_y),len_y,store,ierr) x(start_y:end_y) = x(start_y:end_y) - y(start_y:end_y) else dd = pntr end if pntr = pntr + 1 end do if(dd.eq.-1) then ierr = blas_error_singtria return else start_x = mat%bp1(i) + ofs end_x = mat%bp1(i+1) + ofs -1 len_x = end_x - start_x + 1 start_a = mat%IA2(dd+ofs) + ofs end_a = mat%IA2(dd+ofs+1) + ofs - 1 call invert_right_upper(mat%A(start_a:end_a),& x(start_x:end_x),len_x,store,ierr) end if if(ierr.ne.0) then ierr = blas_error_singtria return end if end if end do deallocate(y,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if end subroutine XRSBV_VBR SHAR_EOF fi # end of overwriting check if test -f 'usaxpy_source.F' then echo shar: will not over-write existing file "'usaxpy_source.F'" else cat << "SHAR_EOF" > 'usaxpy_source.F' subroutine XUSAXPY(x,indx,y,alpha) DCOMPLEX,dimension(:),intent(in) ::x DCOMPLEX,dimension(:),intent(inout) ::y integer,dimension(:),intent(in) ::indx DCOMPLEX,intent(in) ,optional ::alpha integer :: i,t t=size(indx) if(t.gt.0) then if(present(alpha)) then do i=1,t y(indx(i))=y(indx(i))+x(i)*alpha end do else do i=1,t y(indx(i))=y(indx(i))+x(i) end do end if end if end subroutine XUSAXPY SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bdi_source.F' then echo shar: will not over-write existing file "'usconv_bco2bdi_source.F'" else cat << "SHAR_EOF" > 'usconv_bco2bdi_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='BCO') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='BDI' call get_infoa(XSP_DATA%INFOA ,'e',lb,ierr) call get_infoa(XSP_DATA%INFOA ,'f',mb,ierr) call get_infoa(XSP_DATA%INFOA ,'g',kb,ierr) BLDA=min(mb,kb) call XPRE_BCO2BDI(mb,kb,lb,XSP_DATA%A,& XSP_DATA%IA1,XSP_DATA%IA2,BLDA,BNDIAG) nullify(XSP_DATA%IA2) call set_infoa(XSP_DATA%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(XSP_DATA%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(XSP_DATA%INFOA,'f',BLDA,ierr) !blocks per diagonal call set_infoa(XSP_DATA%INFOA,'g',BNDIAG,ierr) !no of diagonals end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bsc_source.F' then echo shar: will not over-write existing file "'usconv_bco2bsc_source.F'" else cat << "SHAR_EOF" > 'usconv_bco2bsc_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='BCO') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='BSC' call get_infoa(XSP_DATA%INFOA,'g',col_dim_in_blocks,ierr) call get_infoa(XSP_DATA%INFOA,'e',col_dim_of_block,ierr) allocate(XSP_DATA%PB(col_dim_in_blocks)) allocate(XSP_DATA%PE(col_dim_in_blocks)) call XPRE_BCO2BSC(XSP_DATA%A,XSP_DATA%IA1,& XSP_DATA%IA2,col_dim_in_blocks,& col_dim_of_block,XSP_DATA%PB,XSP_DATA%PE) nullify(XSP_DATA%IA2) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bsr_source.F' then echo shar: will not over-write existing file "'usconv_bco2bsr_source.F'" else cat << "SHAR_EOF" > 'usconv_bco2bsr_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='BCO') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='BSR' call get_infoa(XSP_DATA%INFOA,'f',row_dim_in_blocks,ierr) call get_infoa(XSP_DATA%INFOA,'e',col_dim_of_block,ierr) allocate(XSP_DATA%PB(row_dim_in_blocks)) allocate(XSP_DATA%PE(row_dim_in_blocks)) call XPRE_BCO2BSR(XSP_DATA%A,XSP_DATA%IA1,XSP_DATA%IA2,& row_dim_in_blocks,col_dim_of_block,XSP_DATA%PB,XSP_DATA%PE) nullify(XSP_DATA%IA2) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_bdi2bco_source.F' then echo shar: will not over-write existing file "'usconv_bdi2bco_source.F'" else cat << "SHAR_EOF" > 'usconv_bdi2bco_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='BDI') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='BCO' allocate(XSP_DATA%IA2(2)) call get_infoa(XSP_DATA%INFOA,'d',lb,ierr) !row-dim of a block call get_infoa(XSP_DATA%INFOA,'f',BLDA,ierr) !blocks per diagonal mb=floor(real(XSP_DATA%M/lb)) kb=floor(real(XSP_DATA%K/lb)) call set_infoa(XSP_DATA%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(XSP_DATA%INFOA,'g',kb,ierr) !col-dim in blocks call XPRE_BDI2BCO(XSP_DATA%A, XSP_DATA%IA1,& XSP_DATA%IA2,BLDA,BNNZ,lb) call set_infoa(XSP_DATA%INFOA,'n',BNNZ,ierr) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_bsc2bco_source.F' then echo shar: will not over-write existing file "'usconv_bsc2bco_source.F'" else cat << "SHAR_EOF" > 'usconv_bsc2bco_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='BSC') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='BCO' s=size(XSP_DATA%IA1) allocate(XSP_DATA%IA2(s)) call PNTR_INV( XSP_DATA%PE, XSP_DATA%IA2) nullify(XSP_DATA%PB) nullify(XSP_DATA%PE) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_bsr2bco_source.F' then echo shar: will not over-write existing file "'usconv_bsr2bco_source.F'" else cat << "SHAR_EOF" > 'usconv_bsr2bco_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='BSR') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='BCO' s=size(XSP_DATA%IA1) allocate(XSP_DATA%IA2(s)) XSP_DATA%IA2=XSP_DATA%IA1 call PNTR_INV( XSP_DATA%PE, XSP_DATA%IA1) nullify(XSP_DATA%PB) nullify(XSP_DATA%PE) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2csc_source.F' then echo shar: will not over-write existing file "'usconv_coo2csc_source.F'" else cat << "SHAR_EOF" > 'usconv_coo2csc_source.F' subroutine XCOO2CSC(a,ierr) integer,intent(inout) :: a type( XSPMAT), pointer :: dspmtx integer ,intent(inout)::ierr integer :: res ierr=-1 call accessdata(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(dspmtx%FIDA=='COO') then call get_infoa(dspmtx%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then dspmtx%FIDA='CSC' allocate(dspmtx%PB(dspmtx%K)) allocate(dspmtx%PE(dspmtx%K)) call XPRE_COO2CSC( dspmtx%A, dspmtx%IA1, dspmtx%IA2,& dspmtx%K, dspmtx%PB, dspmtx%PE) nullify(dspmtx%IA2) end if else ierr = blas_error_param return end if end subroutine XCOO2CSC SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2csr_source.F' then echo shar: will not over-write existing file "'usconv_coo2csr_source.F'" else cat << "SHAR_EOF" > 'usconv_coo2csr_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='COO') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='CSR' allocate(XSP_DATA%PB(XSP_DATA%K)) allocate(XSP_DATA%PE(XSP_DATA%K)) call XPRE_COO2CSR ( XSP_DATA%A, XSP_DATA%IA1, & XSP_DATA%IA2, XSP_DATA%M, XSP_DATA%PB, XSP_DATA%PE) nullify(XSP_DATA%IA2) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2dia_source.F' then echo shar: will not over-write existing file "'usconv_coo2dia_source.F'" else cat << "SHAR_EOF" > 'usconv_coo2dia_source.F' ierr=-1 call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='COO') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='DIA' call XPRE_COO2DIA( XSP_DATA%M, XSP_DATA%K, XSP_DATA%A,& XSP_DATA%IA1, XSP_DATA%IA2,LDA,NDIAG) nullify(XSP_DATA%IA2) nnz = count( XSP_DATA%A.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored ! end if call set_infoa(XSP_DATA%INFOA,'n',nnz,ierr) call set_infoa(XSP_DATA%INFOA,'d',LDA,ierr) !row-dim of val call set_infoa(XSP_DATA%INFOA,'e',NDIAG,ierr) !col-dim of val end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_csc2coo_source.F' then echo shar: will not over-write existing file "'usconv_csc2coo_source.F'" else cat << "SHAR_EOF" > 'usconv_csc2coo_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='CSC') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='COO' s=size(XSP_DATA%A) allocate(XSP_DATA%IA2(s)) call PNTR_INV( XSP_DATA%PE, XSP_DATA%IA2) nullify(XSP_DATA%PB) nullify(XSP_DATA%PE) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_csr2coo_source.F' then echo shar: will not over-write existing file "'usconv_csr2coo_source.F'" else cat << "SHAR_EOF" > 'usconv_csr2coo_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='CSR') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='COO' s=size(XSP_DATA%A) allocate(XSP_DATA%IA2(s)) XSP_DATA%IA2=XSP_DATA%IA1 call PNTR_INV( XSP_DATA%PE, XSP_DATA%IA1) nullify(XSP_DATA%PB) nullify(XSP_DATA%PE) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'usconv_dia2coo_source.F' then echo shar: will not over-write existing file "'usconv_dia2coo_source.F'" else cat << "SHAR_EOF" > 'usconv_dia2coo_source.F' call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(XSP_DATA%FIDA=='DIA') then call get_infoa(XSP_DATA%INFOA ,'c',res,ierr) if(res.eq.COP_OF_SOURCE) then XSP_DATA%FIDA='COO' allocate(XSP_DATA%IA2(2)) call get_infoa(XSP_DATA%INFOA ,'d',LDA,ierr) !row-dim of val call get_infoa(XSP_DATA%INFOA ,'n',NNZ,ierr) call XPRE_DIA2COO(XSP_DATA%A, XSP_DATA%IA1, & XSP_DATA%IA2,LDA,NNZ) end if else ierr = blas_error_param return end if SHAR_EOF fi # end of overwriting check if test -f 'uscr_bco_source.F' then echo shar: will not over-write existing file "'uscr_bco_source.F'" else cat << "SHAR_EOF" > 'uscr_bco_source.F' subroutine XUSCR_BCO(m,n,val,bindx,bjndx,bnnz,mb,kb,lb, & prpty,istat,a) implicit none integer, intent(in) :: m,n,bnnz,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bjndx DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BCO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) call set_infoa(dsp_data%INFOA,'n',bnnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((bnnz.ne.size(bindx)).or.(bnnz.ne.size(bjndx)).or.& (m.ne.mb*lb).or.(n.ne.kb*lb).or.(bnnz*lb*lb.ne.size(val)).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (minval(bjndx).lt.base).or.(maxval(bjndx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => bjndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(bjndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = bjndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_BCO SHAR_EOF fi # end of overwriting check if test -f 'uscr_bdi_source.F' then echo shar: will not over-write existing file "'uscr_bdi_source.F'" else cat << "SHAR_EOF" > 'uscr_bdi_source.F' subroutine XUSCR_BDI(m,n,val,blda,ibdiag,nbdiag,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,blda,nbdiag,mb,kb,lb,prpty integer, dimension(:), intent(inout), target :: ibdiag DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((nbdiag.ne.size(ibdiag)).or.(blda*nbdiag*lb*lb.ne.size(val))& .or.(maxval(ibdiag).gt.kb).or.(minval(ibdiag).lt.-mb).or.& (blda.ne.min(mb,kb))) then ierr = blas_error_param return end if call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BDI' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.blda*nbdiag*lb*lb*0.5) then ! Warning Many zeros stored ! end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',blda,ierr) !blocks per diagonal call set_infoa(dsp_data%INFOA,'g',nbdiag,ierr) !no of diagonals if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => ibdiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(ibdiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = ibdiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_BDI SHAR_EOF fi # end of overwriting check if test -f 'uscr_begin_source.F' then echo shar: will not over-write existing file "'uscr_begin_source.F'" else cat << "SHAR_EOF" > 'uscr_begin_source.F' subroutine XUSCR_BEGIN(m,n,a,istat) implicit none integer ,intent(in) ::m,n integer ,intent(out)::a,istat integer ::nmb,mb type(X_MATRIX),pointer :: XPMATRIX mb=1 istat = -1 if((m.le.0).or.(n.le.0)) then istat = blas_error_param return else call NEW_X_MATRIX(nmb,mb,istat) if (istat.ne.0) then istat = blas_error_memalloc return end if call access_matrix(XPMATRIX,nmb,istat) if (istat.ne.0) then istat = blas_error_param return end if XPMATRIX%DIM(1)=m !nb_of_rows XPMATRIX%DIM(2)=n !nb_of_cols XPMATRIX%format='normal' a=nmb end if end subroutine XUSCR_BEGIN SHAR_EOF fi # end of overwriting check if test -f 'uscr_block_begin_source.F' then echo shar: will not over-write existing file "'uscr_block_begin_source.F'" else cat << "SHAR_EOF" > 'uscr_block_begin_source.F' subroutine XUSCR_BLOCK_BEGIN(Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb,k,l integer ,intent(out)::a,istat integer ::nmb,m type(X_MATRIX),pointer :: XPMATRIX m=1 istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call NEW_X_MATRIX(nmb,m,istat) if (istat.ne.0) return call access_matrix(XPMATRIX,nmb, istat) if (istat.ne.0) return XPMATRIX%DIM(3)=Mb !nb_of_block_rows XPMATRIX%DIM(4)=Nb !nb_of_block_cols XPMATRIX%DIM(5)=k !nb_of_rows_in_block XPMATRIX%DIM(6)=l !nb_of_cols_in_block XPMATRIX%format='block' a=nmb end if istat = 0 end subroutine XUSCR_BLOCK_BEGIN SHAR_EOF fi # end of overwriting check if test -f 'uscr_bsc_source.F' then echo shar: will not over-write existing file "'uscr_bsc_source.F'" else cat << "SHAR_EOF" > 'uscr_bsc_source.F' subroutine XUSCR_BSC(m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((kb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.mb-1+base).or.& (kb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_BSC SHAR_EOF fi # end of overwriting check if test -f 'uscr_bsr_source.F' then echo shar: will not over-write existing file "'uscr_bsr_source.F'" else cat << "SHAR_EOF" > 'uscr_bsr_source.F' subroutine XUSCR_BSR(m,n,val,bindx,bpntrb,bpntre,mb,kb,lb,& prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,lb,prpty integer, dimension(:), intent(inout),target :: bindx,bpntrb,bpntre DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'BSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lb,ierr) !row-dim of a block call set_infoa(dsp_data%INFOA,'e',lb,ierr) !col-dim of a block call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(m.ne.mb*lb).or.(n.ne.kb*lb).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base).or.& (mb.ne.size(bpntre)).or.(nnz*lb*lb.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%pb => bpntrb dsp_data%pe => bpntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%pb = bpntrb dsp_data%pe = bpntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_BSR SHAR_EOF fi # end of overwriting check if test -f 'uscr_coo_source.F' then echo shar: will not over-write existing file "'uscr_coo_source.F'" else cat << "SHAR_EOF" > 'uscr_coo_source.F' subroutine XUSCR_COO(m,n,val,indx,jndx,nnz,prpty,istat,a) implicit none integer, intent(in) :: m,n,nnz,prpty integer, dimension(:), intent(inout),target :: indx,jndx DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options,base logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'COO' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if((nnz.ne.size(indx)).or.(nnz.ne.size(jndx)).or.& (nnz.ne.size(val)).or.(minval(indx).lt.base).or.& (minval(jndx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (maxval(jndx).gt.n-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%IA2 => jndx istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%IA2(size(jndx)),STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%IA2 = jndx istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_COO SHAR_EOF fi # end of overwriting check if test -f 'uscr_csc_source.F' then echo shar: will not over-write existing file "'uscr_csc_source.F'" else cat << "SHAR_EOF" > 'uscr_csc_source.F' subroutine XUSCR_CSC(m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSC' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(n.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.m-1+base).or.& (n.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_CSC SHAR_EOF fi # end of overwriting check if test -f 'uscr_csr_source.F' then echo shar: will not over-write existing file "'uscr_csr_source.F'" else cat << "SHAR_EOF" > 'uscr_csr_source.F' subroutine XUSCR_CSR(m,n,val,indx,pntrb,pntre,prpty,istat,a) implicit none integer, intent(in) :: m,n,prpty integer, dimension(:), intent(inout),target :: indx,pntrb,pntre DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'CSR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = maxval(pntre)-base call set_infoa(dsp_data%INFOA,'n',nnz,ierr) if((nnz.ne.size(indx)).or.(m.ne.size(pntrb)).or.& (minval(indx).lt.base).or.(maxval(indx).gt.n-1+base).or.& (m.ne.size(pntre)).or.(nnz.ne.size(val))) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => indx dsp_data%pb => pntrb dsp_data%pe => pntre istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(indx)),& dsp_data%pb(size(pntrb)),dsp_data%pe(size(pntre))& ,STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = indx dsp_data%pb = pntrb dsp_data%pe = pntre istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_CSR SHAR_EOF fi # end of overwriting check if test -f 'uscr_dia_source.F' then echo shar: will not over-write existing file "'uscr_dia_source.F'" else cat << "SHAR_EOF" > 'uscr_dia_source.F' subroutine XUSCR_DIA(m,n,val,lda,idiag,ndiag,prpty,istat,a) implicit none integer, intent(in) :: m,n,lda,ndiag,prpty integer, dimension(:), intent(inout),target :: idiag DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr,nnz,options,base logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 if((ndiag.ne.size(idiag)).or.(lda*ndiag.ne.size(val)).or.& (maxval(idiag).gt.n).or.(minval(idiag).lt.-m).or.& (lda.ne.min(m,n))) then ierr = blas_error_param return end if call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'DIA' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if nnz = count(val.ne.0.) if(nnz.le.lda*ndiag*0.5) then ! Warning Many zeros stored end if call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',lda,ierr) !row-dim of val call set_infoa(dsp_data%INFOA,'e',ndiag,ierr) !col-dim of val if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => idiag istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(idiag)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = idiag istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_DIA SHAR_EOF fi # end of overwriting check if test -f 'uscr_end_source.F' then echo shar: will not over-write existing file "'uscr_end_source.F'" else cat << "SHAR_EOF" > 'uscr_end_source.F' istat=-1 call access_matrix(XPMATRIX,a,istat) if(istat.ne.0) return prpty=XPMATRIX%property select case(XPMATRIX%format) case('block') call XUSCR_blockend(a,prpty,istat) if(istat.ne.0) return case('vblock') call XUSCR_varend (a,prpty,istat) if(istat.ne.0) return case('normal') call XUSCR_normend(a,prpty,istat) if(istat.ne.0) return case default istat = blas_error_param return end select SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_block_source.F' then echo shar: will not over-write existing file "'uscr_insert_block_source.F'" else cat << "SHAR_EOF" > 'uscr_insert_block_source.F' subroutine XUSCR_INSERT_BLOCK(a,val,bi,bj,istat) implicit none DCOMPLEX ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a,bi,bj integer,intent(out)::istat type(X_MATRIX),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if(istat.ne.0) return select case(pmatrix%format) case('block') call XINS_block(pmatrix,val,bi,bj,istat) case('vblock') call XINS_varblock(pmatrix,val,bi,bj,istat) case default istat = blas_error_param return end select end subroutine XUSCR_INSERT_BLOCK SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_clique_source.F' then echo shar: will not over-write existing file "'uscr_insert_clique_source.F'" else cat << "SHAR_EOF" > 'uscr_insert_clique_source.F' subroutine XUSCR_INSERT_CLIQUE(a,val,indx,jndx,istat) implicit none DCOMPLEX ,dimension(:,:),intent(in) ::val integer ,intent(in) ::a integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx,jndx integer ::i,j,s_row,s_col istat=-1 s_row=size(indx) s_col=size(jndx) do j=1,s_col do i=1,s_row call XUSCR_INSERT_ENTRY(a,val(i,j),& indx(i),jndx(j),istat) if(istat.ne.0) return end do end do end subroutine XUSCR_INSERT_CLIQUE SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_col_source.F' then echo shar: will not over-write existing file "'uscr_insert_col_source.F'" else cat << "SHAR_EOF" > 'uscr_insert_col_source.F' subroutine XUSCR_INSERT_COL (a,j,val,indx,istat) implicit none DCOMPLEX ,dimension(:),intent(in) ::val integer ,intent(in) ::a,j integer ,intent(out) ::istat integer,dimension(:),intent(in)::indx integer ::i,s istat=-1 s=size(val) do i=1,s call XUSCR_INSERT_ENTRY(a,val(i),indx(i),j,istat) if(istat.ne.0) return end do end subroutine XUSCR_INSERT_COL SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_entries_source.F' then echo shar: will not over-write existing file "'uscr_insert_entries_source.F'" else cat << "SHAR_EOF" > 'uscr_insert_entries_source.F' subroutine XUSCR_INSERT_ENTRIES(a,val,indx,jndx,istat) implicit none DCOMPLEX ,dimension(:),intent(in) ::val integer ,intent(in) ::a integer,intent(out)::istat integer,dimension(:),intent(in)::indx,jndx integer ::i istat=-1 do i=1,size(val) call XUSCR_INSERT_ENTRY(a,val(i),indx(i),& jndx(i),istat) if(istat.ne.0) return end do end subroutine XUSCR_INSERT_ENTRIES SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_entry_source.F' then echo shar: will not over-write existing file "'uscr_insert_entry_source.F'" else cat << "SHAR_EOF" > 'uscr_insert_entry_source.F' subroutine XUSCR_INSERT_ENTRY (a,val,i,j,istat) implicit none DCOMPLEX ,intent(in) ::val integer ,intent(in) ::a,i,j integer,intent(out)::istat type(X_MATRIX),pointer ::pmatrix istat=-1 call access_matrix(pmatrix,a,istat) if (istat.ne.0) return select case(pmatrix%format) case('block') call XINS_bl_entr(pmatrix,val,i,j,istat) case('vblock') call XINS_varbl_entr(pmatrix,val,i,j,istat) case('normal') call XINS_entry(pmatrix,val,i,j,istat) case default istat = blas_error_param return end select end subroutine XUSCR_INSERT_ENTRY SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_row_source.F' then echo shar: will not over-write existing file "'uscr_insert_row_source.F'" else cat << "SHAR_EOF" > 'uscr_insert_row_source.F' subroutine XUSCR_INSERT_ROW (a,i,val,jndx,istat) implicit none DCOMPLEX ,dimension(:),intent(in) ::val integer ,intent(in) ::a,i integer,dimension(:),intent(in)::jndx integer ,intent(out)::istat integer ::k,s istat=-1 s=size(val) do k=1,s call XUSCR_INSERT_ENTRY(a,val(k),i,jndx(k),istat) if (istat.ne.0) return end do end subroutine XUSCR_INSERT_ROW SHAR_EOF fi # end of overwriting check if test -f 'uscr_variable_block_begin_source.F' then echo shar: will not over-write existing file "'uscr_variable_block_begin_source.F'" else cat << "SHAR_EOF" > 'uscr_variable_block_begin_source.F' subroutine XUSCR_V_B_BEGIN(Mb,Nb,k,l,a,istat) implicit none integer ,intent(in) ::Mb,Nb integer,dimension(:),target,intent(in)::k,l integer ,intent(out)::a,istat integer ::nmb type(X_MATRIX),pointer :: XPMATRIX istat = -1 if((Mb.le.0).or.(Nb.le.0)) then istat = blas_error_param return else call NEW_X_MATRIX(nmb,Mb, istat) if (istat.ne.0) return call access_matrix(XPMATRIX,nmb, istat) if (istat.ne.0) return XPMATRIX%DIM(3)=Mb !nb_of_block_rows XPMATRIX%DIM(4)=Nb !nb_of_block_cols XPMATRIX%sub_rows=>k XPMATRIX%sub_cols=>l XPMATRIX%trb=1 XPMATRIX%tre=1 XPMATRIX%format='vblock' a=nmb end if istat = 0 end subroutine XUSCR_V_B_BEGIN SHAR_EOF fi # end of overwriting check if test -f 'uscr_vbr_source.F' then echo shar: will not over-write existing file "'uscr_vbr_source.F'" else cat << "SHAR_EOF" > 'uscr_vbr_source.F' subroutine XUSCR_VBR(m,n,val,indx,bindx,rpntr,cpntr,bpntrb,& bpntre,mb,kb,prpty,istat,a) implicit none integer, intent(in) :: m,n,mb,kb,prpty integer, dimension(:), intent(inout),target :: indx,bindx,& rpntr,cpntr,bpntrb,bpntre DCOMPLEX, dimension(:), intent(inout),target :: val integer, intent(inout) :: istat integer, intent(out) :: a integer :: nmb,ierr, options, base , nnz logical :: COPY character :: message type(XSPMAT),pointer :: dsp_data options = istat istat = -1 !if not changed later, routine has failed a = 0 call NEW_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if call accessdata(dsp_data,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if dsp_data%FIDA = 'VBR' dsp_data%M = m dsp_data%K = n call set_descra(dsp_data%DESCRA,prpty,ierr) call get_descra(dsp_data%DESCRA,'b',message,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (message.eq.'C') then base = C_BASE else !Assuming F base base = F_BASE end if call set_infoa(dsp_data%INFOA,'b',base,ierr) nnz = size(bindx) !no. of nonzero blocks call set_infoa(dsp_data%INFOA,'n',nnz,ierr) call set_infoa(dsp_data%INFOA,'d',-1,ierr) !row-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'e',-1,ierr) !col-dim of block NOT fixed call set_infoa(dsp_data%INFOA,'f',mb,ierr) !row-dim in blocks call set_infoa(dsp_data%INFOA,'g',kb,ierr) !col-dim in blocks if((mb.ne.size(bpntrb)).or.(mb.ne.size(bpntre)).or.& (size(val).ne.maxval(indx)-base).or.(minval(indx).lt.base).or.& (minval(bindx).lt.base).or.(maxval(bindx).gt.kb-1+base)) then call usds(nmb,ierr) ierr = blas_error_param return end if if (options.gt.0) then ! decision rule whether or not to copy COPY = .TRUE. if(COPY) then options = -1 !copy else options = 0 !reference end if end if if (options.eq.0) then call set_infoa(dsp_data%INFOA,'c',REF_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! create reference to original matrix dsp_data%A => val dsp_data%IA1 => bindx dsp_data%IA2 => indx dsp_data%pb => bpntrb dsp_data%pe => bpntre dsp_data%bp1 => rpntr dsp_data%bp2 => cpntr istat = 0 else ! The additional required memory is DEALLOCATED later in USDS! call set_infoa(dsp_data%INFOA,'c',COP_OF_SOURCE,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if ! copy original data allocate(dsp_data%A(size(val)),dsp_data%IA1(size(bindx)),& dsp_data%IA2(size(indx)),& dsp_data%pb(size(bpntrb)),dsp_data%pe(size(bpntre)),& dsp_data%bp1(size(rpntr)),dsp_data%bp2(size(cpntr)),& STAT=ierr) if(ierr.ne.0) then ierr = blas_error_memalloc return end if dsp_data%A = val dsp_data%IA1 = bindx dsp_data%IA2 = indx dsp_data%pb = bpntrb dsp_data%pe = bpntre dsp_data%bp1 = rpntr dsp_data%bp2 = cpntr istat = 1 end if if(istat.ge.0) a = nmb end subroutine XUSCR_VBR SHAR_EOF fi # end of overwriting check if test -f 'usdot_source.F' then echo shar: will not over-write existing file "'usdot_source.F'" else cat << "SHAR_EOF" > 'usdot_source.F' DCOMPLEX function XUSDOT(x,indx,y,conj) implicit none integer,dimension(:),intent(in) :: indx DCOMPLEX ,dimension(:),intent(in) ::x,y DCOMPLEX ,dimension(:),allocatable :: zy integer,optional ::conj integer ::t intrinsic dot_product,conjg,cmplx t=size(indx) if(t.le.0) then XUSDOT=0. else allocate(zy(t)) zy= y(indx) if(present(conj)) then XUSDOT=dot_product(x,zy) else XUSDOT=dot_product(conjg(cmplx(x)),zy) end if deallocate(zy) end if end function XUSDOT SHAR_EOF fi # end of overwriting check if test -f 'usds_source.F' then echo shar: will not over-write existing file "'usds_source.F'" else cat << "SHAR_EOF" > 'usds_source.F' call accessdata(XSP_DATA,nmb,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_infoa(XSP_DATA%INFOA,'c',val,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if(val.eq.COP_OF_SOURCE) then ! *** Deallocate extra storage for copy of matrix *** ! select case(XSP_DATA%FIDA) case('COO','BCO') deallocate(XSP_DATA%A,XSP_DATA%IA1,XSP_DATA%IA2,STAT=ierr) case('CSC','BSC') deallocate(XSP_DATA%A,XSP_DATA%IA1,XSP_DATA%pb,XSP_DATA%pe,& STAT=ierr) case('CSR','BSR') deallocate(XSP_DATA%A,XSP_DATA%IA1,XSP_DATA%pb,XSP_DATA%pe,& STAT=ierr) case('DIA','BDI') deallocate(XSP_DATA%A,XSP_DATA%IA1,STAT=ierr) case('VBR') deallocate(XSP_DATA%A,XSP_DATA%IA1,XSP_DATA%IA2,& XSP_DATA%PB,XSP_DATA%PE,XSP_DATA%BP1,XSP_DATA%BP2& ,STAT=ierr) case default ierr = blas_error_param return end select if(ierr.ne.0) then ierr = blas_error_memdeloc return end if end if call DEL_XSP(nmb,ierr) if (ierr.ne.0) then ierr = blas_error_memdeloc return end if SHAR_EOF fi # end of overwriting check if test -f 'usga_source.F' then echo shar: will not over-write existing file "'usga_source.F'" else cat << "SHAR_EOF" > 'usga_source.F' subroutine XUSGA(y,x,indx) DCOMPLEX ,dimension(:),intent(inout) ::x DCOMPLEX ,dimension(:),intent(in) ::y integer,dimension(:),intent(in)::indx integer ::t,i t=size(x) if(t.gt.0) then do i=1,t x(i)=y(indx(i)) end do end if end subroutine XUSGA SHAR_EOF fi # end of overwriting check if test -f 'usgp_source.F' then echo shar: will not over-write existing file "'usgp_source.F'" else cat << "SHAR_EOF" > 'usgp_source.F' m=0 ierr=-1 if (a.ge.0) then call accessdata(XSP_DATA,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_valid_handle) then m=1 end if else call XACCESS_MATRIX(XMATRIX,a,ierr) if (ierr.ne.0) then if (pname.eq.blas_valid_handle) then m=-1 elseif (pname.eq.blas_invalid_handle) then m=1 else m=-1 end if return elseif(pname.eq.blas_new_handle) then if (XMATRIX%new.eq.1) then m=1 else m=0 end if elseif(pname.eq.blas_open_handle) then if (XMATRIX%new.eq.0) then m=1 else m=0 end if else m=-1 return end if end if if(pname.eq.blas_zero_base) then call get_descra(XSP_DATA%DESCRA,'b',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_one_base) then call get_descra(XSP_DATA%DESCRA,'b',test,ierr) if(test.eq.'F') then m=1 end if elseif(pname.eq.blas_general) then call get_descra(XSP_DATA%DESCRA,'t',test,ierr) if(test.eq.'G') then m=1 end if elseif(pname.eq.blas_symmetric) then call get_descra(XSP_DATA%DESCRA,'t',test,ierr) if(test.eq.'S') then m=1 end if elseif(pname.eq.blas_hermitian) then call get_descra(XSP_DATA%DESCRA,'t',test,ierr) if(test.eq.'H') then m=1 end if elseif(pname.eq.blas_upper_triangular) then call get_descra(XSP_DATA%DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(XSP_DATA%DESCRA,'a',test,ierr) if(test.eq.'U') then m=1 end if end if elseif(pname.eq.blas_lower_triangular) then call get_descra(XSP_DATA%DESCRA,'t',test,ierr) if(test.eq.'T') then call get_descra(XSP_DATA%DESCRA,'a',test,ierr) if(test.eq.'L') then m=1 end if end if elseif(pname.eq.blas_row_major) then call get_descra(XSP_DATA%DESCRA,'f',test,ierr) if(test.eq.'R') then m=1 end if elseif(pname.eq.blas_col_major) then call get_descra(XSP_DATA%DESCRA,'f',test,ierr) if(test.eq.'C') then m=1 end if elseif(pname.eq.blas_complex) then if ((rest.eq.CSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_real) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.DSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_integer) then if (rest.eq.ISP_MATRIX) then m=1 else m=0 end if elseif(pname.eq.blas_double_precision) then if ((rest.eq.DSP_MATRIX).or.(rest.eq.ZSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_single_precision) then if ((rest.eq.SSP_MATRIX).or.(rest.eq.CSP_MATRIX)) then m=1 else m=0 end if elseif(pname.eq.blas_num_rows) then m=XSP_DATA%M elseif(pname.eq.blas_num_cols) then m=XSP_DATA%K elseif(pname.eq.blas_num_nonzeros) then call get_infoa(XSP_DATA%INFOA,'n',m,ierr) else m=-1 return end if SHAR_EOF fi # end of overwriting check if test -f 'usgz_source.F' then echo shar: will not over-write existing file "'usgz_source.F'" else cat << "SHAR_EOF" > 'usgz_source.F' subroutine XUSGZ(y,x,indx) DCOMPLEX ,dimension(:),intent(out) ::x DCOMPLEX ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer ::i,t t=size(indx) if(t.gt.0) then call usga(y,x,indx) do i=1,t y(indx(i))=0 end do end if end subroutine XUSGZ SHAR_EOF fi # end of overwriting check if test -f 'usmm_source.F' then echo shar: will not over-write existing file "'usmm_source.F'" else cat << "SHAR_EOF" > 'usmm_source.F' subroutine XUSMM(a,b,c,ierr,transa,alpha) implicit none integer, intent(in) :: a DCOMPLEX, dimension(:,:), intent(in) :: b DCOMPLEX, dimension(:,:), intent(inout) :: c integer, intent(out) :: ierr integer, intent(in), optional :: transa DCOMPLEX, intent(in), optional :: alpha DCOMPLEX, dimension(:), allocatable :: z type(XSPMAT), pointer :: dspmtx integer transa_work,i DCOMPLEX :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq.ZZERO) then !no matrix multiplication necessary else call ACCESSDATA_XSP(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(c,1)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,b(:,i),z,ierr) case('CSC') call rmbv_csc(dspmtx,b(:,i),z,ierr) case('CSR') call rmbv_csr(dspmtx,b(:,i),z,ierr) case('DIA') call rmbv_dia(dspmtx,b(:,i),z,ierr) case('BCO') call rmbv_bco(dspmtx,b(:,i),z,ierr) case('BSC') call rmbv_bsc(dspmtx,b(:,i),z,ierr) case('BSR') call rmbv_bsr(dspmtx,b(:,i),z,ierr) case('BDI') call rmbv_bdi(dspmtx,b(:,i),z,ierr) case('VBR') call rmbv_vbr(dspmtx,b(:,i),z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx,CONJUG(b(:,i)),z,ierr) case('CSC') call lmbv_csc(dspmtx,CONJUG(b(:,i)),z,ierr) case('CSR') call lmbv_csr(dspmtx,CONJUG(b(:,i)),z,ierr) case('DIA') call lmbv_dia(dspmtx,CONJUG(b(:,i)),z,ierr) case('BCO') call lmbv_bco(dspmtx,CONJUG(b(:,i)),z,ierr) case('BSC') call lmbv_bsc(dspmtx,CONJUG(b(:,i)),z,ierr) case('BSR') call lmbv_bsr(dspmtx,CONJUG(b(:,i)),z,ierr) case('BDI') call lmbv_bdi(dspmtx,CONJUG(b(:,i)),z,ierr) case('VBR') call lmbv_vbr(dspmtx,CONJUG(b(:,i)),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return else if(transa_work.eq.ORIGIN_MATRIX) then c(:,i) = alpha_work * z + c(:,i) else c(:,i) = alpha_work * (CONJUG(z)) + c(:,i) end if end if end do deallocate(z,STAT=ierr) end if ierr = 0 end subroutine XUSMM SHAR_EOF fi # end of overwriting check if test -f 'usmv_source.F' then echo shar: will not over-write existing file "'usmv_source.F'" else cat << "SHAR_EOF" > 'usmv_source.F' subroutine XUSMV(a,x,y,ierr,transa,alpha) implicit none integer, intent(in) :: a DCOMPLEX, dimension(:), intent(in) :: x DCOMPLEX, dimension(:), intent(inout) :: y integer, intent(out) :: ierr integer, intent(in), optional :: transa DCOMPLEX, intent(in), optional :: alpha DCOMPLEX, dimension(:), allocatable :: z type(XSPMAT), pointer :: dspmtx integer :: transa_work DCOMPLEX :: alpha_work ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.eq.ZZERO) then !no matrix multiplication necessary else call ACCESSDATA_XSP(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if allocate(z(size(y)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rmbv_coo(dspmtx,x,z,ierr) case('CSC') call rmbv_csc(dspmtx,x,z,ierr) case('CSR') call rmbv_csr(dspmtx,x,z,ierr) case('DIA') call rmbv_dia(dspmtx,x,z,ierr) case('BCO') call rmbv_bco(dspmtx,x,z,ierr) case('BSC') call rmbv_bsc(dspmtx,x,z,ierr) case('BSR') call rmbv_bsr(dspmtx,x,z,ierr) case('BDI') call rmbv_bdi(dspmtx,x,z,ierr) case('VBR') call rmbv_vbr(dspmtx,x,z,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lmbv_coo(dspmtx,CONJUG(x),z,ierr) case('CSC') call lmbv_csc(dspmtx,CONJUG(x),z,ierr) case('CSR') call lmbv_csr(dspmtx,CONJUG(x),z,ierr) case('DIA') call lmbv_dia(dspmtx,CONJUG(x),z,ierr) case('BCO') call lmbv_bco(dspmtx,CONJUG(x),z,ierr) case('BSC') call lmbv_bsc(dspmtx,CONJUG(x),z,ierr) case('BSR') call lmbv_bsr(dspmtx,CONJUG(x),z,ierr) case('BDI') call lmbv_bdi(dspmtx,CONJUG(x),z,ierr) case('VBR') call lmbv_vbr(dspmtx,CONJUG(x),z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then deallocate(z,STAT=ierr) return end if if(transa_work.eq.ORIGIN_MATRIX) then y = alpha_work * z + y else y = alpha_work * (CONJUG(z)) + y end if deallocate(z,STAT=ierr) end if ierr = 0 end subroutine XUSMV SHAR_EOF fi # end of overwriting check if test -f 'ussc_source.F' then echo shar: will not over-write existing file "'ussc_source.F'" else cat << "SHAR_EOF" > 'ussc_source.F' subroutine XUSSC(x,y,indx) DCOMPLEX,dimension(:),intent(in) ::x DCOMPLEX ,dimension(:),intent(inout) ::y integer,dimension(:),intent(in)::indx integer :: i,t t=size(indx) if(t.gt.0) then do i=1,t y(indx(i))= x(i) end do end if end subroutine XUSSC SHAR_EOF fi # end of overwriting check if test -f 'ussm_source.F' then echo shar: will not over-write existing file "'ussm_source.F'" else cat << "SHAR_EOF" > 'ussm_source.F' subroutine XUSSM(a,b,ierr,transa,alpha) integer, intent(in) :: a DCOMPLEX, dimension(:,:), intent(inout) :: b integer, intent(out) :: ierr integer, intent(in), optional :: transa DCOMPLEX, intent(in), optional :: alpha integer :: transa_work,i DCOMPLEX :: alpha_work DCOMPLEX, dimension(:,:), allocatable :: z type(XSPMAT), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne.0.) then call ACCESSDATA_XSP(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(b,1),size(b,2)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z=CONJUG(b) do i = 1,size(b,2) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,b(:,i),ierr) case('CSC') call rsbv_csc(dspmtx,b(:,i),ierr) case('CSR') call rsbv_csr(dspmtx,b(:,i),ierr) case('DIA') call rsbv_dia(dspmtx,b(:,i),ierr) case('BCO') call rsbv_bco(dspmtx,b(:,i),ierr) case('BSC') call rsbv_bsc(dspmtx,b(:,i),ierr) case('BSR') call rsbv_bsr(dspmtx,b(:,i),ierr) case('BDI') call rsbv_bdi(dspmtx,b(:,i),ierr) case('VBR') call rsbv_vbr(dspmtx,b(:,i),ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z(:,i),ierr) case('CSC') call lsbv_csc(dspmtx,z(:,i),ierr) case('CSR') call lsbv_csr(dspmtx,z(:,i),ierr) case('DIA') call lsbv_dia(dspmtx,z(:,i),ierr) case('BCO') call lsbv_bco(dspmtx,z(:,i),ierr) case('BSC') call lsbv_bsc(dspmtx,z(:,i),ierr) case('BSR') call lsbv_bsr(dspmtx,z(:,i),ierr) case('BDI') call lsbv_bdi(dspmtx,z(:,i),ierr) case('VBR') call lsbv_vbr(dspmtx,z(:,i),ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end do end if if(transa_work.eq.ORIGIN_MATRIX) then b = alpha_work * b else b = alpha_work * (CONJUG(z)) end if ierr = 0 end subroutine XUSSM SHAR_EOF fi # end of overwriting check if test -f 'ussp_source.F' then echo shar: will not over-write existing file "'ussp_source.F'" else cat << "SHAR_EOF" > 'ussp_source.F' call access_matrix(XPMATRIX,a,istat) XPMATRIX%property=m SHAR_EOF fi # end of overwriting check if test -f 'ussv_source.F' then echo shar: will not over-write existing file "'ussv_source.F'" else cat << "SHAR_EOF" > 'ussv_source.F' subroutine XUSSV(a,x,ierr,transa,alpha) integer, intent(in) :: a DCOMPLEX, intent(inout) :: x(:) integer, intent(out) :: ierr integer, intent(in), optional :: transa DCOMPLEX, intent(in), optional :: alpha integer :: transa_work DCOMPLEX :: alpha_work DCOMPLEX, dimension(:), allocatable :: z type(XSPMAT), pointer :: dspmtx character :: type ierr = -1 if (present(transa)) then transa_work = transa else transa_work = ORIGIN_MATRIX end if if (present(alpha)) then alpha_work = alpha else alpha_work = 1. end if if (alpha_work.ne.ZZERO) then call ACCESSDATA_XSP(dspmtx,a,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if call get_descra(dspmtx%DESCRA,'t',type,ierr) if (ierr.ne.0) then ierr = blas_error_param return end if if (type.ne.'T') then ierr = blas_error_param return end if allocate(z(size(x)),STAT=ierr) if (ierr.ne.0) then ierr = blas_error_memalloc return end if z=CONJUG(x) select case(transa_work) case(ORIGIN_MATRIX) select case(dspmtx%FIDA) case('COO') call rsbv_coo(dspmtx,x,ierr) case('CSC') call rsbv_csc(dspmtx,x,ierr) case('CSR') call rsbv_csr(dspmtx,x,ierr) case('DIA') call rsbv_dia(dspmtx,x,ierr) case('BCO') call rsbv_bco(dspmtx,x,ierr) case('BSC') call rsbv_bsc(dspmtx,x,ierr) case('BSR') call rsbv_bsr(dspmtx,x,ierr) case('BDI') call rsbv_bdi(dspmtx,x,ierr) case('VBR') call rsbv_vbr(dspmtx,x,ierr) case default ierr = blas_error_param end select case(TRANSP_MATRIX) select case(dspmtx%FIDA) case('COO') call lsbv_coo(dspmtx,z,ierr) case('CSC') call lsbv_csc(dspmtx,z,ierr) case('CSR') call lsbv_csr(dspmtx,z,ierr) case('DIA') call lsbv_dia(dspmtx,z,ierr) case('BCO') call lsbv_bco(dspmtx,z,ierr) case('BSC') call lsbv_bsc(dspmtx,z,ierr) case('BSR') call lsbv_bsr(dspmtx,z,ierr) case('BDI') call lsbv_bdi(dspmtx,z,ierr) case('VBR') call lsbv_vbr(dspmtx,z,ierr) case default ierr = blas_error_param end select case default ierr = blas_error_param end select if (ierr.ne.0) then return end if end if if(transa_work.eq.ORIGIN_MATRIX) then x = alpha_work * x else x = alpha_work * (CONJUG(z)) end if ierr = 0 end subroutine XUSSV SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'SPEC_ARITH' then mkdir 'SPEC_ARITH' fi cd 'SPEC_ARITH' if test -f 'doubleComplex' then echo shar: will not over-write existing file "'doubleComplex'" else cat << "SHAR_EOF" > 'doubleComplex' #define EXP d /* definition of type and intrinsic functions */ #define DCOMPLEX complex(KIND=dp) #define DREAL real(KIND=dp) #define SQROOT dsqrt #define REALPART dreal #define CONJUG conjg /* definition of own types, etc */ #define XSP_MATRIX ZSP_MATRIX #define XSPMAT zspmat #define ACCESSDATA_XSP accessdata_zsp #define NEW_XSP new_zsp #define DEL_XSP del_zsp #define XSP_DATA zsp_data #define XSP_HANDLE zsp_handle #define XSP_LINKNODE zsp_linknode #define XINS_INIT zins_init #define XSP_INIT zsp_init #define XSP_FIRST zsp_first #define XSP_LAST zsp_last #define X_MATRIX z_matrix #define XMATRIX zmatrix #define X_MATRIX_start z_matrix_start #define X_ELEMENT_start z_element_start #define X_INELEMENT z_inelement #define X_ELEMENT z_element #define XPMATRIX zpmatrix #define XTYPES ztypes /* definition of the constants */ #define ZZERO (0.0d0, 0.0d0) #define ZONE (1.0d0, 0.0d0) #define ZEROREAL 0.0d0 #define ONEREAL 1.0d0 /* definition of own routines */ #define XLMBV_BCO zlmbv_bco #define XLMBV_BDI zlmbv_bdi #define XLMBV_BSC zlmbv_bsc #define XLMBV_BSR zlmbv_bsr #define XLMBV_COO zlmbv_coo #define XLMBV_CSC zlmbv_csc #define XLMBV_CSR zlmbv_csr #define XLMBV_DIA zlmbv_dia #define XLMBV_VBR zlmbv_vbr #define XLSBV_BCO zlsbv_bco #define XLSBV_BDI zlsbv_bdi #define XLSBV_BSC zlsbv_bsc #define XLSBV_BSR zlsbv_bsr #define XLSBV_COO zlsbv_coo #define XLSBV_CSC zlsbv_csc #define XLSBV_CSR zlsbv_csr #define XLSBV_DIA zlsbv_dia #define XLSBV_VBR zlsbv_vbr #define XRMBV_BCO zrmbv_bco #define XRMBV_BDI zrmbv_bdi #define XRMBV_BSC zrmbv_bsc #define XRMBV_BSR zrmbv_bsr #define XRMBV_COO zrmbv_coo #define XRMBV_CSC zrmbv_csc #define XRMBV_CSR zrmbv_csr #define XRMBV_DIA zrmbv_dia #define XRMBV_VBR zrmbv_vbr #define XRSBV_BCO zrsbv_bco #define XRSBV_BDI zrsbv_bdi #define XRSBV_BSC zrsbv_bsc #define XRSBV_BSR zrsbv_bsr #define XRSBV_COO zrsbv_coo #define XRSBV_CSC zrsbv_csc #define XRSBV_CSR zrsbv_csr #define XRSBV_DIA zrsbv_dia #define XRSBV_VBR zrsbv_vbr #define XUSCR_BCO zuscr_bco #define XUSCR_BDI zuscr_bdi #define XUSCR_BSC zuscr_bsc #define XUSCR_BSR zuscr_bsr #define XUSCR_COO zuscr_coo #define XUSCR_CSC zuscr_csc #define XUSCR_CSR zuscr_csr #define XUSCR_DIA zuscr_dia #define XUSCR_VBR zuscr_vbr #define XUSMV zusmv #define XUSMM zusmm #define XUSSV zussv #define XUSSM zussm #define XBLOCK_MULT zblock_mult_vec #define XBLOCK_Z_MULT zblock_Z_mult_vec #define XBLOCK_T_MULT zblock_T_mult_vec #define XBLOCK_H_MULT zblock_H_mult_vec #define XINV_LL zinvert_left_lower #define XINV_T_LL zinvert_T_left_lower #define XINV_RU zinvert_right_upper #define XINV_T_RU zinvert_T_right_upper #define XBLOCK_R_MULT zblock_r_mult_vec #define XBLOCK_L_MULT zblock_l_mult_vec #define XINV_R_LL zinvert_r_left_lower #define XINV_L_LL zinvert_l_left_lower #define XINV_L_RU zinvert_l_right_upper #define XINV_R_RU zinvert_r_right_upper #define XUSDOT zusdot #define XUSAXPY zusaxpy #define XUSGA zusga #define XUSGZ zusgz #define XUSSC zussc #define XB_UP_ORDER zb_up_order #define XA_ROW_COL zA_row_col #define XDETECT_DIAG zdetect_diag #define XAB_ROW_COL zAb_row_col #define XDETECT_BDIAG zdetect_bdiag #define XPRE_COO2DIA zpre_usconv_coo2dia #define XPRE_DIA2COO zpre_usconv_dia2coo #define XPRE_BCO2BDI zpre_usconv_bco2bdi #define XPRE_BDI2BCO zpre_usconv_bdi2bco #define XPRE_COO2CSR zpre_usconv_coo2csr #define XPRE_COO2CSC zpre_usconv_coo2csc #define XPRE_BCO2BSR zpre_usconv_bco2bsr #define XPRE_BCO2BSC zpre_usconv_bco2bsc #define XBCO2BDI zusconv_bco2bdi #define XBDI2BCO zusconv_bdi2bco #define XCOO2CSR zusconv_coo2csr #define XCOO2CSC zusconv_coo2csc #define XBCO2BSR zusconv_bco2bsr #define XBCO2BSC zusconv_bco2bsc #define XCOO2DIA zusconv_coo2dia #define XDIA2COO zusconv_dia2coo #define XCSR2COO zusconv_csr2coo #define XCSC2COO zusconv_csc2coo #define XBSC2BCO zusconv_bsc2bco #define XBSR2BCO zusconv_bsr2bco #define NEW_X_MATRIX new_z_matrix #define DELOC_X_MATRIX dealloc_z_matrix #define XACCESS_MATRIX zaccess_matrix #define NEW_X_ELEMENT new_z_element #define X_ELEMENT_start z_element_start #define DELOC_X_ELEMENT dealloc_z_element #define XACCESS_ELEMENT zaccess_element #define X_ELEMENT_NUM z_element_num #define X_DEALLOC z_dealloc #define XINS_entry zINS_entry #define XINS_bl_entr zINS_bl_entr #define XINS_block zINS_block #define XINS_varblock zINS_varblock #define XINS_varbl_entr zINS_varbl_entr #define XUSCR_varend zuscr_varend #define XUSCR_normend zuscr_normend #define XUSCR_blockend zuscr_blockend #define XUSCR_BEGIN zuscr_begin #define XUSCR_BLOCK_BEGIN zuscr_block_begin #define XUSCR_V_B_BEGIN zuscr_variable_block_begin #define XUSCR_INSERT_ENTRY zuscr_insert_entry #define XUSCR_INSERT_ENTRIES zuscr_insert_entries #define XUSCR_INSERT_COL zuscr_insert_col #define XUSCR_INSERT_ROW zuscr_insert_row #define XUSCR_INSERT_CLIQUE zuscr_insert_clique #define XUSCR_INSERT_BLOCK zuscr_insert_block #define XUSCR_END zuscr_end #define XUSGP zusgp #define XUSSP zussp SHAR_EOF fi # end of overwriting check if test -f 'doublePrecision' then echo shar: will not over-write existing file "'doublePrecision'" else cat << "SHAR_EOF" > 'doublePrecision' #define EXP d /* definition of type and intrinsic functions */ #define DCOMPLEX real(KIND=dp) #define DREAL real(KIND=dp) #define SQROOT dsqrt #define REALPART #define CONJUG /* definition of own types */ #define XSP_MATRIX DSP_MATRIX #define XSPMAT dspmat #define ACCESSDATA_XSP accessdata_dsp #define NEW_XSP new_dsp #define DEL_XSP del_dsp #define XSP_DATA dsp_data #define XSP_HANDLE dsp_handle #define XSP_LINKNODE dsp_linknode #define XINS_INIT dins_init #define XSP_INIT dsp_init #define XSP_FIRST dsp_first #define XSP_LAST dsp_last #define X_MATRIX d_matrix #define XMATRIX dmatrix #define X_MATRIX_start d_matrix_start #define X_ELEMENT_start d_element_start #define X_INELEMENT d_inelement #define X_ELEMENT d_element #define XPMATRIX dpmatrix #define XTYPES dtypes /* definition of the constants */ #define ZZERO 0.0d0 #define ZONE 1.0d0 #define ZEROREAL 0.0d0 #define ONEREAL 1.0d0 /* definition of own routines */ #define XLMBV_BCO dlmbv_bco #define XLMBV_BDI dlmbv_bdi #define XLMBV_BSC dlmbv_bsc #define XLMBV_BSR dlmbv_bsr #define XLMBV_COO dlmbv_coo #define XLMBV_CSC dlmbv_csc #define XLMBV_CSR dlmbv_csr #define XLMBV_DIA dlmbv_dia #define XLMBV_VBR dlmbv_vbr #define XLSBV_BCO dlsbv_bco #define XLSBV_BDI dlsbv_bdi #define XLSBV_BSC dlsbv_bsc #define XLSBV_BSR dlsbv_bsr #define XLSBV_COO dlsbv_coo #define XLSBV_CSC dlsbv_csc #define XLSBV_CSR dlsbv_csr #define XLSBV_DIA dlsbv_dia #define XLSBV_VBR dlsbv_vbr #define XRMBV_BCO drmbv_bco #define XRMBV_BDI drmbv_bdi #define XRMBV_BSC drmbv_bsc #define XRMBV_BSR drmbv_bsr #define XRMBV_COO drmbv_coo #define XRMBV_CSC drmbv_csc #define XRMBV_CSR drmbv_csr #define XRMBV_DIA drmbv_dia #define XRMBV_VBR drmbv_vbr #define XRSBV_BCO drsbv_bco #define XRSBV_BDI drsbv_bdi #define XRSBV_BSC drsbv_bsc #define XRSBV_BSR drsbv_bsr #define XRSBV_COO drsbv_coo #define XRSBV_CSC drsbv_csc #define XRSBV_CSR drsbv_csr #define XRSBV_DIA drsbv_dia #define XRSBV_VBR drsbv_vbr #define XUSCR_BCO duscr_bco #define XUSCR_BDI duscr_bdi #define XUSCR_BSC duscr_bsc #define XUSCR_BSR duscr_bsr #define XUSCR_COO duscr_coo #define XUSCR_CSC duscr_csc #define XUSCR_CSR duscr_csr #define XUSCR_DIA duscr_dia #define XUSCR_VBR duscr_vbr #define XUSMV dusmv #define XUSMM dusmm #define XUSSV dussv #define XUSSM dussm #define XBLOCK_MULT dblock_mult_vec #define XBLOCK_Z_MULT dblock_Z_mult_vec #define XBLOCK_T_MULT dblock_T_mult_vec #define XBLOCK_H_MULT dblock_H_mult_vec #define XINV_LL dinvert_left_lower #define XINV_T_LL dinvert_T_left_lower #define XINV_RU dinvert_right_upper #define XINV_T_RU dinvert_T_right_upper #define XBLOCK_R_MULT dblock_r_mult_vec #define XBLOCK_L_MULT dblock_l_mult_vec #define XINV_R_LL dinvert_r_left_lower #define XINV_L_LL dinvert_l_left_lower #define XINV_L_RU dinvert_l_right_upper #define XINV_R_RU dinvert_r_right_upper #define XUSDOT dusdot #define XUSAXPY dusaxpy #define XUSGA dusga #define XUSGZ dusgz #define XUSSC dussc #define XB_UP_ORDER db_up_order #define XA_ROW_COL dA_row_col #define XDETECT_DIAG ddetect_diag #define XAB_ROW_COL dAb_row_col #define XDETECT_BDIAG ddetect_bdiag #define XPRE_COO2DIA dpre_usconv_coo2dia #define XPRE_DIA2COO dpre_usconv_dia2coo #define XPRE_BCO2BDI dpre_usconv_bco2bdi #define XPRE_BDI2BCO dpre_usconv_bdi2bco #define XPRE_COO2CSR dpre_usconv_coo2csr #define XPRE_COO2CSC dpre_usconv_coo2csc #define XPRE_BCO2BSR dpre_usconv_bco2bsr #define XPRE_BCO2BSC dpre_usconv_bco2bsc #define XBCO2BDI dusconv_bco2bdi #define XBDI2BCO dusconv_bdi2bco #define XCOO2CSR dusconv_coo2csr #define XCOO2CSC dusconv_coo2csc #define XBCO2BSR dusconv_bco2bsr #define XBCO2BSC dusconv_bco2bsc #define XCOO2DIA dusconv_coo2dia #define XDIA2COO dusconv_dia2coo #define XCSR2COO dusconv_csr2coo #define XCSC2COO dusconv_csc2coo #define XBSC2BCO dusconv_bsc2bco #define XBSR2BCO dusconv_bsr2bco #define NEW_X_MATRIX new_d_matrix #define DELOC_X_MATRIX dealloc_d_matrix #define XACCESS_MATRIX daccess_matrix #define NEW_X_ELEMENT new_d_element #define DELOC_X_ELEMENT dealloc_d_element #define XACCESS_ELEMENT daccess_element #define X_ELEMENT_NUM d_element_num #define X_DEALLOC d_dealloc #define XINS_entry dINS_entry #define XINS_bl_entr dINS_bl_entr #define XINS_block dINS_block #define XINS_varblock dINS_varblock #define XINS_varbl_entr dINS_varbl_entr #define XUSCR_varend duscr_varend #define XUSCR_normend duscr_normend #define XUSCR_blockend duscr_blockend #define XUSCR_BEGIN duscr_begin #define XUSCR_BLOCK_BEGIN duscr_block_begin #define XUSCR_V_B_BEGIN duscr_variable_block_begin #define XUSCR_INSERT_ENTRY duscr_insert_entry #define XUSCR_INSERT_ENTRIES duscr_insert_entries #define XUSCR_INSERT_COL duscr_insert_col #define XUSCR_INSERT_ROW duscr_insert_row #define XUSCR_INSERT_CLIQUE duscr_insert_clique #define XUSCR_INSERT_BLOCK duscr_insert_block #define XUSCR_END duscr_end #define XUSGP dusgp #define XUSSP dussp SHAR_EOF fi # end of overwriting check if test -f 'integer' then echo shar: will not over-write existing file "'integer'" else cat << "SHAR_EOF" > 'integer' #define EXP /* definition of type and intrinsic functions */ #define DCOMPLEX integer #define DREAL integer #define SQROOT #define REALPART #define CONJUG /* definition of own types */ #define XSP_MATRIX ISP_MATRIX #define XSPMAT ispmat #define ACCESSDATA_XSP accessdata_isp #define NEW_XSP new_isp #define DEL_XSP del_isp #define XSP_DATA isp_data #define XSP_HANDLE isp_handle #define XSP_LINKNODE isp_linknode #define XINS_INIT iins_init #define XSP_INIT isp_init #define XSP_FIRST isp_first #define XSP_LAST isp_last #define X_MATRIX i_matrix #define XMATRIX imatrix #define X_MATRIX_start i_matrix_start #define X_ELEMENT_start i_element_start #define X_INELEMENT i_inelement #define X_ELEMENT i_element #define XPMATRIX ipmatrix #define XTYPES itypes /* definition of the constants */ #define ZZERO 0 #define ZONE 1 #define ZEROREAL 0 #define ONEREAL 1 /* definition of own routines */ #define XLMBV_BCO ilmbv_bco #define XLMBV_BDI ilmbv_bdi #define XLMBV_BSC ilmbv_bsc #define XLMBV_BSR ilmbv_bsr #define XLMBV_COO ilmbv_coo #define XLMBV_CSC ilmbv_csc #define XLMBV_CSR ilmbv_csr #define XLMBV_DIA ilmbv_dia #define XLMBV_VBR ilmbv_vbr #define XLSBV_BCO ilsbv_bco #define XLSBV_BDI ilsbv_bdi #define XLSBV_BSC ilsbv_bsc #define XLSBV_BSR ilsbv_bsr #define XLSBV_COO ilsbv_coo #define XLSBV_CSC ilsbv_csc #define XLSBV_CSR ilsbv_csr #define XLSBV_DIA ilsbv_dia #define XLSBV_VBR ilsbv_vbr #define XRMBV_BCO irmbv_bco #define XRMBV_BDI irmbv_bdi #define XRMBV_BSC irmbv_bsc #define XRMBV_BSR irmbv_bsr #define XRMBV_COO irmbv_coo #define XRMBV_CSC irmbv_csc #define XRMBV_CSR irmbv_csr #define XRMBV_DIA irmbv_dia #define XRMBV_VBR irmbv_vbr #define XRSBV_BCO irsbv_bco #define XRSBV_BDI irsbv_bdi #define XRSBV_BSC irsbv_bsc #define XRSBV_BSR irsbv_bsr #define XRSBV_COO irsbv_coo #define XRSBV_CSC irsbv_csc #define XRSBV_CSR irsbv_csr #define XRSBV_DIA irsbv_dia #define XRSBV_VBR irsbv_vbr #define XUSCR_BCO iuscr_bco #define XUSCR_BDI iuscr_bdi #define XUSCR_BSC iuscr_bsc #define XUSCR_BSR iuscr_bsr #define XUSCR_COO iuscr_coo #define XUSCR_CSC iuscr_csc #define XUSCR_CSR iuscr_csr #define XUSCR_DIA iuscr_dia #define XUSCR_VBR iuscr_vbr #define XUSMV iusmv #define XUSMM iusmm #define XUSSV iussv #define XUSSM iussm #define XBLOCK_MULT iblock_mult_vec #define XBLOCK_Z_MULT iblock_Z_mult_vec #define XBLOCK_T_MULT iblock_T_mult_vec #define XBLOCK_H_MULT iblock_H_mult_vec #define XINV_LL iinvert_left_lower #define XINV_T_LL iinvert_T_left_lower #define XINV_RU iinvert_right_upper #define XINV_T_RU iinvert_T_right_upper #define XBLOCK_R_MULT iblock_r_mult_vec #define XBLOCK_L_MULT iblock_l_mult_vec #define XINV_R_LL iinvert_r_left_lower #define XINV_L_LL iinvert_l_left_lower #define XINV_L_RU iinvert_l_right_upper #define XINV_R_RU iinvert_r_right_upper #define XUSDOT iusdot #define XUSAXPY iusaxpy #define XUSGA iusga #define XUSGZ iusgz #define XUSSC iussc #define XB_UP_ORDER ib_up_order #define XA_ROW_COL iA_row_col #define XDETECT_DIAG idetect_diag #define XAB_ROW_COL iAb_row_col #define XDETECT_BDIAG idetect_bdiag #define XPRE_COO2DIA ipre_usconv_coo2dia #define XPRE_DIA2COO ipre_usconv_dia2coo #define XPRE_BCO2BDI ipre_usconv_bco2bdi #define XPRE_BDI2BCO ipre_usconv_bdi2bco #define XPRE_COO2CSR ipre_usconv_coo2csr #define XPRE_COO2CSC ipre_usconv_coo2csc #define XPRE_BCO2BSR ipre_usconv_bco2bsr #define XPRE_BCO2BSC ipre_usconv_bco2bsc #define XBCO2BDI iusconv_bco2bdi #define XBDI2BCO iusconv_bdi2bco #define XCOO2CSR iusconv_coo2csr #define XCOO2CSC iusconv_coo2csc #define XBCO2BSR iusconv_bco2bsr #define XBCO2BSC iusconv_bco2bsc #define XCOO2DIA iusconv_coo2dia #define XDIA2COO iusconv_dia2coo #define XCSR2COO iusconv_csr2coo #define XCSC2COO iusconv_csc2coo #define XBSC2BCO iusconv_bsc2bco #define XBSR2BCO iusconv_bsr2bco #define NEW_X_MATRIX new_i_matrix #define DELOC_X_MATRIX dealloc_i_matrix #define XACCESS_MATRIX iaccess_matrix #define NEW_X_ELEMENT new_i_element #define X_ELEMENT_start i_element_start #define DELOC_X_ELEMENT dealloc_i_element #define XACCESS_ELEMENT iaccess_element #define X_ELEMENT_NUM i_element_num #define X_DEALLOC i_dealloc #define XINS_entry iINS_entry #define XINS_block iINS_block #define XINS_bl_entr iINS_bl_entr #define XINS_varblock iINS_varblock #define XINS_varbl_entr iINS_varbl_entr #define XUSCR_varend iuscr_varend #define XUSCR_normend iuscr_normend #define XUSCR_blockend iuscr_blockend #define XUSCR_BEGIN iuscr_begin #define XUSCR_BLOCK_BEGIN iuscr_block_begin #define XUSCR_V_B_BEGIN iuscr_variable_block_begin #define XUSCR_INSERT_ENTRY iuscr_insert_entry #define XUSCR_INSERT_ENTRIES iuscr_insert_entries #define XUSCR_INSERT_COL iuscr_insert_col #define XUSCR_INSERT_ROW iuscr_insert_row #define XUSCR_INSERT_CLIQUE iuscr_insert_clique #define XUSCR_INSERT_BLOCK iuscr_insert_block #define XUSCR_END iuscr_end #define XUSGP iusgp #define XUSSP iussp SHAR_EOF fi # end of overwriting check if test -f 'singleComplex' then echo shar: will not over-write existing file "'singleComplex'" else cat << "SHAR_EOF" > 'singleComplex' #define EXP e /* definition of type and intrinsic functions */ #define DCOMPLEX complex(KIND=sp) #define DREAL real(KIND=sp) #define SQROOT sqrt #define REALPART real #define CONJUG conjg /* definition of own types */ #define XSP_MATRIX CSP_MATRIX #define XSPMAT cspmat #define ACCESSDATA_XSP accessdata_csp #define NEW_XSP new_csp #define DEL_XSP del_csp #define XSP_DATA csp_data #define XSP_HANDLE csp_handle #define XSP_LINKNODE csp_linknode #define XINS_INIT cins_init #define XSP_INIT csp_init #define XSP_FIRST csp_first #define XSP_LAST csp_last #define X_MATRIX c_matrix #define XMATRIX cmatrix #define X_MATRIX_start c_matrix_start #define X_ELEMENT_start c_element_start #define X_INELEMENT c_inelement #define X_ELEMENT c_element #define XPMATRIX cpmatrix #define XTYPES ctypes /* definition of the constants */ #define ZZERO (0.0e0, 0.0e0) #define ZONE (1.0e0, 0.0e0) #define ZEROREAL 0.0e0 #define ONEREAL 1.0e0 /* definition of own routines */ #define XLMBV_BCO clmbv_bco #define XLMBV_BDI clmbv_bdi #define XLMBV_BSC clmbv_bsc #define XLMBV_BSR clmbv_bsr #define XLMBV_COO clmbv_coo #define XLMBV_CSC clmbv_csc #define XLMBV_CSR clmbv_csr #define XLMBV_DIA clmbv_dia #define XLMBV_VBR clmbv_vbr #define XLSBV_BCO clsbv_bco #define XLSBV_BDI clsbv_bdi #define XLSBV_BSC clsbv_bsc #define XLSBV_BSR clsbv_bsr #define XLSBV_COO clsbv_coo #define XLSBV_CSC clsbv_csc #define XLSBV_CSR clsbv_csr #define XLSBV_DIA clsbv_dia #define XLSBV_VBR clsbv_vbr #define XRMBV_BCO crmbv_bco #define XRMBV_BDI crmbv_bdi #define XRMBV_BSC crmbv_bsc #define XRMBV_BSR crmbv_bsr #define XRMBV_COO crmbv_coo #define XRMBV_CSC crmbv_csc #define XRMBV_CSR crmbv_csr #define XRMBV_DIA crmbv_dia #define XRMBV_VBR crmbv_vbr #define XRSBV_BCO crsbv_bco #define XRSBV_BDI crsbv_bdi #define XRSBV_BSC crsbv_bsc #define XRSBV_BSR crsbv_bsr #define XRSBV_COO crsbv_coo #define XRSBV_CSC crsbv_csc #define XRSBV_CSR crsbv_csr #define XRSBV_DIA crsbv_dia #define XRSBV_VBR crsbv_vbr #define XUSCR_BCO cuscr_bco #define XUSCR_BDI cuscr_bdi #define XUSCR_BSC cuscr_bsc #define XUSCR_BSR cuscr_bsr #define XUSCR_COO cuscr_coo #define XUSCR_CSC cuscr_csc #define XUSCR_CSR cuscr_csr #define XUSCR_DIA cuscr_dia #define XUSCR_VBR cuscr_vbr #define XUSMV cusmv #define XUSMM cusmm #define XUSSV cussv #define XUSSM cussm #define XBLOCK_MULT cblock_mult_vec #define XBLOCK_Z_MULT cblock_Z_mult_vec #define XBLOCK_T_MULT cblock_T_mult_vec #define XBLOCK_H_MULT cblock_H_mult_vec #define XINV_LL cinvert_left_lower #define XINV_T_LL cinvert_T_left_lower #define XINV_RU cinvert_right_upper #define XINV_T_RU cinvert_T_right_upper #define XBLOCK_R_MULT cblock_r_mult_vec #define XBLOCK_L_MULT cblock_l_mult_vec #define XINV_R_LL cinvert_r_left_lower #define XINV_L_LL cinvert_l_left_lower #define XINV_L_RU cinvert_l_right_upper #define XINV_R_RU cinvert_r_right_upper #define XUSDOT cusdot #define XUSAXPY cusaxpy #define XUSGA cusga #define XUSGZ cusgz #define XUSSC cussc #define XB_UP_ORDER cb_up_order #define XA_ROW_COL cA_row_col #define XDETECT_DIAG cdetect_diag #define XAB_ROW_COL cAb_row_col #define XDETECT_BDIAG cdetect_bdiag #define XPRE_COO2DIA cpre_usconv_coo2dia #define XPRE_DIA2COO cpre_usconv_dia2coo #define XPRE_BCO2BDI cpre_usconv_bco2bdi #define XPRE_BDI2BCO cpre_usconv_bdi2bco #define XPRE_COO2CSR cpre_usconv_coo2csr #define XPRE_COO2CSC cpre_usconv_coo2csc #define XPRE_BCO2BSR cpre_usconv_bco2bsr #define XPRE_BCO2BSC cpre_usconv_bco2bsc #define XBCO2BDI cusconv_bco2bdi #define XBDI2BCO cusconv_bdi2bco #define XCOO2CSR cusconv_coo2csr #define XCOO2CSC cusconv_coo2csc #define XBCO2BSR cusconv_bco2bsr #define XBCO2BSC cusconv_bco2bsc #define XCOO2DIA cusconv_coo2dia #define XDIA2COO cusconv_dia2coo #define XCSR2COO cusconv_csr2coo #define XCSC2COO cusconv_csc2coo #define XBSC2BCO cusconv_bsc2bco #define XBSR2BCO cusconv_bsr2bco #define NEW_X_MATRIX new_c_matrix #define DELOC_X_MATRIX dealloc_c_matrix #define XACCESS_MATRIX caccess_matrix #define NEW_X_ELEMENT new_c_element #define DELOC_X_ELEMENT dealloc_c_element #define XACCESS_ELEMENT caccess_element #define X_ELEMENT_NUM c_element_num #define X_DEALLOC c_dealloc #define XINS_entry cINS_entry #define XINS_block cINS_block #define XINS_bl_entr cINS_bl_entr #define XINS_varblock cINS_varblock #define XINS_varbl_entr cINS_varbl_entr #define XUSCR_varend cuscr_varend #define XUSCR_normend cuscr_normend #define XUSCR_blockend cuscr_blockend #define XUSCR_BEGIN cuscr_begin #define XUSCR_BLOCK_BEGIN cuscr_block_begin #define XUSCR_V_B_BEGIN cuscr_variable_block_begin #define XUSCR_INSERT_ENTRY cuscr_insert_entry #define XUSCR_INSERT_ENTRIES cuscr_insert_entries #define XUSCR_INSERT_COL cuscr_insert_col #define XUSCR_INSERT_ROW cuscr_insert_row #define XUSCR_INSERT_CLIQUE cuscr_insert_clique #define XUSCR_INSERT_BLOCK cuscr_insert_block #define XUSCR_END cuscr_end #define XUSGP cusgp #define XUSSP cussp SHAR_EOF fi # end of overwriting check if test -f 'singlePrecision' then echo shar: will not over-write existing file "'singlePrecision'" else cat << "SHAR_EOF" > 'singlePrecision' #define EXP e /* definition of type and intrinsic functions */ #define DCOMPLEX real(KIND=sp) #define DREAL real(KIND=sp) #define SQROOT sqrt #define REALPART #define CONJUG /* definition of own types */ #define XSP_MATRIX SSP_MATRIX #define XSPMAT sspmat #define ACCESSDATA_XSP accessdata_ssp #define NEW_XSP new_ssp #define DEL_XSP del_ssp #define XSP_DATA ssp_data #define XSP_HANDLE ssp_handle #define XSP_LINKNODE ssp_linknode #define XINS_INIT sins_init #define XSP_INIT ssp_init #define XSP_FIRST ssp_first #define XSP_LAST ssp_last #define X_MATRIX s_matrix #define XMATRIX smatrix #define X_MATRIX_start s_matrix_start #define X_ELEMENT_start s_element_start #define X_INELEMENT s_inelement #define X_ELEMENT s_element #define XPMATRIX spmatrix #define XTYPES stypes /* definition of the constants */ #define ZZERO 0.0e0 #define ZONE 1.0e0 #define ZEROREAL 0.0e0 #define ONEREAL 1.0e0 /* definition of own routines */ #define XLMBV_BCO slmbv_bco #define XLMBV_BDI slmbv_bdi #define XLMBV_BSC slmbv_bsc #define XLMBV_BSR slmbv_bsr #define XLMBV_COO slmbv_coo #define XLMBV_CSC slmbv_csc #define XLMBV_CSR slmbv_csr #define XLMBV_DIA slmbv_dia #define XLMBV_VBR slmbv_vbr #define XLSBV_BCO slsbv_bco #define XLSBV_BDI slsbv_bdi #define XLSBV_BSC slsbv_bsc #define XLSBV_BSR slsbv_bsr #define XLSBV_COO slsbv_coo #define XLSBV_CSC slsbv_csc #define XLSBV_CSR slsbv_csr #define XLSBV_DIA slsbv_dia #define XLSBV_VBR slsbv_vbr #define XRMBV_BCO srmbv_bco #define XRMBV_BDI srmbv_bdi #define XRMBV_BSC srmbv_bsc #define XRMBV_BSR srmbv_bsr #define XRMBV_COO srmbv_coo #define XRMBV_CSC srmbv_csc #define XRMBV_CSR srmbv_csr #define XRMBV_DIA srmbv_dia #define XRMBV_VBR srmbv_vbr #define XRSBV_BCO srsbv_bco #define XRSBV_BDI srsbv_bdi #define XRSBV_BSC srsbv_bsc #define XRSBV_BSR srsbv_bsr #define XRSBV_COO srsbv_coo #define XRSBV_CSC srsbv_csc #define XRSBV_CSR srsbv_csr #define XRSBV_DIA srsbv_dia #define XRSBV_VBR srsbv_vbr #define XUSCR_BCO suscr_bco #define XUSCR_BDI suscr_bdi #define XUSCR_BSC suscr_bsc #define XUSCR_BSR suscr_bsr #define XUSCR_COO suscr_coo #define XUSCR_CSC suscr_csc #define XUSCR_CSR suscr_csr #define XUSCR_DIA suscr_dia #define XUSCR_VBR suscr_vbr #define XUSMV susmv #define XUSMM susmm #define XUSSV sussv #define XUSSM sussm #define XBLOCK_MULT sblock_mult_vec #define XBLOCK_Z_MULT sblock_Z_mult_vec #define XBLOCK_T_MULT sblock_T_mult_vec #define XBLOCK_H_MULT sblock_H_mult_vec #define XINV_LL sinvert_left_lower #define XINV_T_LL sinvert_T_left_lower #define XINV_RU sinvert_right_upper #define XINV_T_RU sinvert_T_right_upper #define XBLOCK_R_MULT sblock_r_mult_vec #define XBLOCK_L_MULT sblock_l_mult_vec #define XINV_R_LL sinvert_r_left_lower #define XINV_L_LL sinvert_l_left_lower #define XINV_L_RU sinvert_l_right_upper #define XINV_R_RU sinvert_r_right_upper #define XUSDOT susdot #define XUSAXPY susaxpy #define XUSGA susga #define XUSGZ susgz #define XUSSC sussc #define XB_UP_ORDER sb_up_order #define XA_ROW_COL sA_row_col #define XDETECT_DIAG sdetect_diag #define XAB_ROW_COL sAb_row_col #define XDETECT_BDIAG sdetect_bdiag #define XPRE_COO2DIA spre_usconv_coo2dia #define XPRE_DIA2COO spre_usconv_dia2coo #define XPRE_BCO2BDI spre_usconv_bco2bdi #define XPRE_BDI2BCO spre_usconv_bdi2bco #define XPRE_COO2CSR spre_usconv_coo2csr #define XPRE_COO2CSC spre_usconv_coo2csc #define XPRE_BCO2BSR spre_usconv_bco2bsr #define XPRE_BCO2BSC spre_usconv_bco2bsc #define XBCO2BDI susconv_bco2bdi #define XBDI2BCO susconv_bdi2bco #define XCOO2CSR susconv_coo2csr #define XCOO2CSC susconv_coo2csc #define XBCO2BSR susconv_bco2bsr #define XBCO2BSC susconv_bco2bsc #define XCOO2DIA susconv_coo2dia #define XDIA2COO susconv_dia2coo #define XCSR2COO susconv_csr2coo #define XCSC2COO susconv_csc2coo #define XBSC2BCO susconv_bsc2bco #define XBSR2BCO susconv_bsr2bco #define NEW_X_MATRIX new_s_matrix #define DELOC_X_MATRIX dealloc_s_matrix #define XACCESS_MATRIX saccess_matrix #define NEW_X_ELEMENT new_s_element #define X_ELEMENT_start s_element_start #define DELOC_X_ELEMENT dealloc_s_element #define XACCESS_ELEMENT saccess_element #define X_ELEMENT_NUM s_element_num #define X_DEALLOC s_dealloc #define XINS_entry sINS_entry #define XINS_block sINS_block #define XINS_bl_entr sINS_bl_entr #define XINS_varblock sINS_varblock #define XINS_varbl_entr sINS_varbl_entr #define XUSCR_varend suscr_varend #define XUSCR_normend suscr_normend #define XUSCR_blockend suscr_blockend #define XUSCR_BEGIN suscr_begin #define XUSCR_BLOCK_BEGIN suscr_block_begin #define XUSCR_V_B_BEGIN suscr_variable_block_begin #define XUSCR_INSERT_ENTRY suscr_insert_entry #define XUSCR_INSERT_ENTRIES suscr_insert_entries #define XUSCR_INSERT_COL suscr_insert_col #define XUSCR_INSERT_ROW suscr_insert_row #define XUSCR_INSERT_CLIQUE suscr_insert_clique #define XUSCR_INSERT_BLOCK suscr_insert_block #define XUSCR_END suscr_end #define XUSGP susgp #define XUSSP sussp SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'TARGET_FILES' then mkdir 'TARGET_FILES' fi cd 'TARGET_FILES' if test -f 'INSERTING_target.F' then echo shar: will not over-write existing file "'INSERTING_target.F'" else cat << "SHAR_EOF" > 'INSERTING_target.F' 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 ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integerINSERTING_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionINSERTING_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionINSERTING_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexINSERTING_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexINSERTING_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_INSERTING SHAR_EOF fi # end of overwriting check if test -f 'INS_ROUTINER_target.F' then echo shar: will not over-write existing file "'INS_ROUTINER_target.F'" else cat << "SHAR_EOF" > 'INS_ROUTINER_target.F' 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 ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integerINS_ROUTINER_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionINS_ROUTINER_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionINS_ROUTINER_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexINS_ROUTINER_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexINS_ROUTINER_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_INS_ROUTINER SHAR_EOF fi # end of overwriting check if test -f 'conv_tools_target.F' then echo shar: will not over-write existing file "'conv_tools_target.F'" else cat << "SHAR_EOF" > 'conv_tools_target.F' module mod_conv_tools use blas_sparse_namedconstants interface b_up_order module procedure ib_up_order module procedure sb_up_order module procedure db_up_order module procedure cb_up_order module procedure zb_up_order end interface interface A_row_col module procedure iA_row_col module procedure sA_row_col module procedure dA_row_col module procedure cA_row_col module procedure zA_row_col end interface interface detect_diag module procedure idetect_diag module procedure sdetect_diag module procedure ddetect_diag module procedure cdetect_diag module procedure zdetect_diag end interface interface Ab_row_col module procedure iAb_row_col module procedure sAb_row_col module procedure dAb_row_col module procedure cAb_row_col module procedure zAb_row_col end interface interface detect_bdiag module procedure idetect_bdiag module procedure sdetect_bdiag module procedure ddetect_bdiag module procedure cdetect_bdiag module procedure zdetect_bdiag end interface interface pre_usconv_coo2csr module procedure ipre_usconv_coo2csr module procedure spre_usconv_coo2csr module procedure dpre_usconv_coo2csr module procedure cpre_usconv_coo2csr module procedure zpre_usconv_coo2csr end interface interface pre_usconv_coo2csc module procedure ipre_usconv_coo2csc module procedure spre_usconv_coo2csc module procedure dpre_usconv_coo2csc module procedure cpre_usconv_coo2csc module procedure zpre_usconv_coo2csc end interface interface pre_usconv_bco2bsc module procedure ipre_usconv_bco2bsc module procedure spre_usconv_bco2bsc module procedure dpre_usconv_bco2bsc module procedure cpre_usconv_bco2bsc module procedure zpre_usconv_bco2bsc end interface interface pre_usconv_bco2bsr module procedure ipre_usconv_bco2bsr module procedure spre_usconv_bco2bsr module procedure dpre_usconv_bco2bsr module procedure cpre_usconv_bco2bsr module procedure zpre_usconv_bco2bsr end interface interface pre_usconv_coo2dia module procedure ipre_usconv_coo2dia module procedure spre_usconv_coo2dia module procedure dpre_usconv_coo2dia module procedure cpre_usconv_coo2dia module procedure zpre_usconv_coo2dia end interface interface pre_usconv_dia2coo module procedure ipre_usconv_dia2coo module procedure spre_usconv_dia2coo module procedure dpre_usconv_dia2coo module procedure cpre_usconv_dia2coo module procedure zpre_usconv_dia2coo end interface interface pre_usconv_bco2bdi module procedure ipre_usconv_bco2bdi module procedure spre_usconv_bco2bdi module procedure dpre_usconv_bco2bdi module procedure cpre_usconv_bco2bdi module procedure zpre_usconv_bco2bdi end interface interface pre_usconv_bdi2bco module procedure ipre_usconv_bdi2bco module procedure spre_usconv_bdi2bco module procedure dpre_usconv_bdi2bco module procedure cpre_usconv_bdi2bco module procedure zpre_usconv_bdi2bco end interface contains subroutine up_order(INDX,RES_INDX) implicit none integer,pointer,dimension(:) ::INDX integer,dimension(:),allocatable ::tes integer,pointer,dimension(:) ::RES_INDX integer,dimension(1)::c integer ::i,s integer :: dummy intrinsic maxval intrinsic minloc s=size(INDX) allocate(tes(s)) tes=INDX dummy = maxval(tes)+1 do i=1,s c=minloc(tes) RES_INDX(i)=c(1) tes(c(1))=dummy end do deallocate(tes) end subroutine up_order function counter(INDX,value) implicit none integer ,pointer,dimension(:)::INDX integer ,intent(in)::value integer ::counter,s,j,k s=size(INDX) k=0 do j=1,s if(INDX(j)==value) then k=k+1 end if end do counter=k end function counter subroutine PNTR(PNTRB,PNTRE,M_K,INDX) implicit none integer ,pointer,dimension(:)::PNTRB,PNTRE integer ,pointer,dimension(:) :: INDX integer ,intent(in) :: M_K integer ::j,s s=size(INDX) PNTRB(1)=1 PNTRE(M_K)=s+1 do j=2,M_K PNTRB(j)=PNTRB(j-1)+counter(INDX,j-1) PNTRE(j-1)=PNTRB(j) end do end subroutine PNTR subroutine final_order(JNDX,final_indx,row_subdv) implicit none integer,pointer,dimension(:)::JNDX,row_subdv integer,pointer,dimension(:)::final_indx integer,pointer,dimension(:) :: test_int,test_ind integer ::d,k,s,i d=1 s=size(row_subdv) do i=1,s if(row_subdv(i)>0) then allocate(test_int(row_subdv(i))) allocate(test_ind(row_subdv(i))) test_int=JNDX((/(i,i=d,d+row_subdv(i)-1,1)/)) call up_order(test_int,test_ind) do k=1,row_subdv(i) final_indx(d+k-1)=test_ind(k)+d-1 end do deallocate(test_int) deallocate(test_ind) end if d=d+row_subdv(i) end do end subroutine final_order subroutine PNTR_INV(PNTRE,INDX) implicit none integer,pointer ,dimension(:)::PNTRE integer,pointer ,dimension(:)::INDX integer :: i,j,s s=size(PNTRE) do j=1,PNTRE(1)-1 INDX(j)=1 end do do i=1,s-1 if(PNTRE(i).ne.PNTRE(i+1)) then do j=PNTRE(i),PNTRE(i+1)-1 INDX(j)=i+1 end do end if end do end subroutine PNTR_INV !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& #include "integerconv_tools_source.F" !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& #include "singlePrecisionconv_tools_source.F" !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& #include "doublePrecisionconv_tools_source.F" !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& #include "singleComplexconv_tools_source.F" !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& #include "doubleComplexconv_tools_source.F" !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& end module mod_conv_tools SHAR_EOF fi # end of overwriting check if test -f 'dense_target.F' then echo shar: will not over-write existing file "'dense_target.F'" else cat << "SHAR_EOF" > 'dense_target.F' module mod_dense_mat_algos ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : DENSE MATRIX ALGORITHMS FOR BLOCK SPARSE MATRICES ! ********************************************************************** use properties implicit none interface block_mult_vec module procedure iblock_mult_vec module procedure sblock_mult_vec module procedure dblock_mult_vec module procedure cblock_mult_vec module procedure zblock_mult_vec end interface interface block_Z_mult_vec module procedure iblock_Z_mult_vec module procedure sblock_Z_mult_vec module procedure dblock_Z_mult_vec module procedure cblock_Z_mult_vec module procedure zblock_Z_mult_vec end interface interface block_T_mult_vec module procedure iblock_T_mult_vec module procedure sblock_T_mult_vec module procedure dblock_T_mult_vec module procedure cblock_T_mult_vec module procedure zblock_T_mult_vec end interface interface block_H_mult_vec module procedure iblock_H_mult_vec module procedure sblock_H_mult_vec module procedure dblock_H_mult_vec module procedure cblock_H_mult_vec module procedure zblock_H_mult_vec end interface interface invert_left_lower module procedure iinvert_left_lower module procedure sinvert_left_lower module procedure dinvert_left_lower module procedure cinvert_left_lower module procedure zinvert_left_lower end interface interface invert_T_left_lower module procedure iinvert_T_left_lower module procedure sinvert_T_left_lower module procedure dinvert_T_left_lower module procedure cinvert_T_left_lower module procedure zinvert_T_left_lower end interface interface invert_right_upper module procedure iinvert_right_upper module procedure sinvert_right_upper module procedure dinvert_right_upper module procedure cinvert_right_upper module procedure zinvert_right_upper end interface interface invert_T_right_upper module procedure iinvert_T_right_upper module procedure sinvert_T_right_upper module procedure dinvert_T_right_upper module procedure cinvert_T_right_upper module procedure zinvert_T_right_upper end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerdense_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisiondense_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisiondense_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexdense_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexdense_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_dense_mat_algos SHAR_EOF fi # end of overwriting check if test -f 'info_target.F' then echo shar: will not over-write existing file "'info_target.F'" else cat << "SHAR_EOF" > 'info_target.F' module mod_info ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : FOR DEBUGGING ONLY !!! ! "print" displays data for given handle number ! ********************************************************************** use representation_of_data use properties implicit none contains subroutine print(nmb,ierr) implicit none intrinsic modulo integer, intent(in) :: nmb integer, intent(out) :: ierr type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer :: rest,base,copy,nnz,rowdim,coldim character :: style,diag,type,part,store rest = modulo(nmb,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerinfo_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisioninfo_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisioninfo_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexinfo_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexinfo_source.F" ! ********************************************************************** case default write(*,*) 'Wrong matrix type !' ierr = -1 end select end subroutine print end module mod_info SHAR_EOF fi # end of overwriting check if test -f 'link_target.F' then echo shar: will not over-write existing file "'link_target.F'" else cat << "SHAR_EOF" > 'link_target.F' module representation_of_data ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : THE PRINCIPAL DATA STRUCTURE ! Matrix data is stored in nodes of a linked list ! Node number is the handle number ! new: creates new node WITHOUT initialization ! del: frees unused memory, does NOT care if there ! is other memory that should be freed first ! accessdata: given a handle number, it returns a ! pointer to the matrix inside the relevant node ! ! ********************************************************************** use types use properties implicit none interface accessdata module procedure accessdata_isp module procedure accessdata_ssp module procedure accessdata_dsp module procedure accessdata_csp module procedure accessdata_zsp end interface type isp_linknode type(ispmat) :: contents integer :: number type(isp_linknode), pointer :: pntr end type isp_linknode type ssp_linknode type(sspmat) :: contents integer :: number type(ssp_linknode), pointer :: pntr end type ssp_linknode type dsp_linknode type(dspmat) :: contents integer :: number type(dsp_linknode), pointer :: pntr end type dsp_linknode type csp_linknode type(cspmat) :: contents integer :: number type(csp_linknode), pointer :: pntr end type csp_linknode type zsp_linknode type(zspmat) :: contents integer :: number type(zsp_linknode), pointer :: pntr end type zsp_linknode type(isp_linknode), pointer,SAVE,PRIVATE :: isp_first, isp_last type(ssp_linknode), pointer,SAVE,PRIVATE :: ssp_first, ssp_last type(dsp_linknode), pointer,SAVE,PRIVATE :: dsp_first, dsp_last type(csp_linknode), pointer,SAVE,PRIVATE :: csp_first, csp_last type(zsp_linknode), pointer,SAVE,PRIVATE :: zsp_first, zsp_last logical,SAVE,PRIVATE :: isp_init = .FALSE. logical,SAVE,PRIVATE :: ssp_init = .FALSE. logical,SAVE,PRIVATE :: dsp_init = .FALSE. logical,SAVE,PRIVATE :: csp_init = .FALSE. logical,SAVE,PRIVATE :: zsp_init = .FALSE. contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlink_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlink_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlink_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlink_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlink_source.F" ! ********************************************************************** ! ! ********************************************************************** end module representation_of_data SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bco_target.F' then echo shar: will not over-write existing file "'lmbv_bco_target.F'" else cat << "SHAR_EOF" > 'lmbv_bco_target.F' module mod_lmbv_bco ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BCO'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_bco module procedure ilmbv_bco module procedure slmbv_bco module procedure dlmbv_bco module procedure clmbv_bco module procedure zlmbv_bco end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_bco SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bdi_target.F' then echo shar: will not over-write existing file "'lmbv_bdi_target.F'" else cat << "SHAR_EOF" > 'lmbv_bdi_target.F' module mod_lmbv_bdi ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BDI'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_bdi module procedure ilmbv_bdi module procedure slmbv_bdi module procedure dlmbv_bdi module procedure clmbv_bdi module procedure zlmbv_bdi end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_bdi SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bsc_target.F' then echo shar: will not over-write existing file "'lmbv_bsc_target.F'" else cat << "SHAR_EOF" > 'lmbv_bsc_target.F' module mod_lmbv_bsc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BSC'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_bsc module procedure ilmbv_bsc module procedure slmbv_bsc module procedure dlmbv_bsc module procedure clmbv_bsc module procedure zlmbv_bsc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_bsc SHAR_EOF fi # end of overwriting check if test -f 'lmbv_bsr_target.F' then echo shar: will not over-write existing file "'lmbv_bsr_target.F'" else cat << "SHAR_EOF" > 'lmbv_bsr_target.F' module mod_lmbv_bsr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BSR'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_bsr module procedure ilmbv_bsr module procedure slmbv_bsr module procedure dlmbv_bsr module procedure clmbv_bsr module procedure zlmbv_bsr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_bsr SHAR_EOF fi # end of overwriting check if test -f 'lmbv_coo_target.F' then echo shar: will not over-write existing file "'lmbv_coo_target.F'" else cat << "SHAR_EOF" > 'lmbv_coo_target.F' module mod_lmbv_coo ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH TRANSPOSE IN 'COO'-STORAGE ! lmbv = Left Multiplication By Vector: y^T = x^TA ! ********************************************************************** use representation_of_data use properties implicit none interface lmbv_coo module procedure ilmbv_coo module procedure slmbv_coo module procedure dlmbv_coo module procedure clmbv_coo module procedure zlmbv_coo end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_coo SHAR_EOF fi # end of overwriting check if test -f 'lmbv_csc_target.F' then echo shar: will not over-write existing file "'lmbv_csc_target.F'" else cat << "SHAR_EOF" > 'lmbv_csc_target.F' module mod_lmbv_csc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'CSC'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties implicit none interface lmbv_csc module procedure ilmbv_csc module procedure slmbv_csc module procedure dlmbv_csc module procedure clmbv_csc module procedure zlmbv_csc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_csc SHAR_EOF fi # end of overwriting check if test -f 'lmbv_csr_target.F' then echo shar: will not over-write existing file "'lmbv_csr_target.F'" else cat << "SHAR_EOF" > 'lmbv_csr_target.F' module mod_lmbv_csr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'CSR'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties implicit none interface lmbv_csr module procedure ilmbv_csr module procedure slmbv_csr module procedure dlmbv_csr module procedure clmbv_csr module procedure zlmbv_csr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_csr SHAR_EOF fi # end of overwriting check if test -f 'lmbv_dia_target.F' then echo shar: will not over-write existing file "'lmbv_dia_target.F'" else cat << "SHAR_EOF" > 'lmbv_dia_target.F' module mod_lmbv_dia ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'DIA'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties implicit none interface lmbv_dia module procedure ilmbv_dia module procedure slmbv_dia module procedure dlmbv_dia module procedure clmbv_dia module procedure zlmbv_dia end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_dia SHAR_EOF fi # end of overwriting check if test -f 'lmbv_vbr_target.F' then echo shar: will not over-write existing file "'lmbv_vbr_target.F'" else cat << "SHAR_EOF" > 'lmbv_vbr_target.F' module mod_lmbv_vbr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'VBR'-STORAGE ! lmbv = Left Multiplication By Vector: y^T=x^TA ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lmbv_vbr module procedure ilmbv_vbr module procedure slmbv_vbr module procedure dlmbv_vbr module procedure clmbv_vbr module procedure zlmbv_vbr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lmbv_vbr SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bco_target.F' then echo shar: will not over-write existing file "'lsbv_bco_target.F'" else cat << "SHAR_EOF" > 'lsbv_bco_target.F' module mod_lsbv_bco ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BCO'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use mod_hash use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_bco module procedure ilsbv_bco module procedure slsbv_bco module procedure dlsbv_bco module procedure clsbv_bco module procedure zlsbv_bco end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_bco SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bdi_target.F' then echo shar: will not over-write existing file "'lsbv_bdi_target.F'" else cat << "SHAR_EOF" > 'lsbv_bdi_target.F' module mod_lsbv_bdi ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BDI'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_bdi module procedure ilsbv_bdi module procedure slsbv_bdi module procedure dlsbv_bdi module procedure clsbv_bdi module procedure zlsbv_bdi end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_bdi SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bsc_target.F' then echo shar: will not over-write existing file "'lsbv_bsc_target.F'" else cat << "SHAR_EOF" > 'lsbv_bsc_target.F' module mod_lsbv_bsc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BSC'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_bsc module procedure ilsbv_bsc module procedure slsbv_bsc module procedure dlsbv_bsc module procedure clsbv_bsc module procedure zlsbv_bsc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_bsc SHAR_EOF fi # end of overwriting check if test -f 'lsbv_bsr_target.F' then echo shar: will not over-write existing file "'lsbv_bsr_target.F'" else cat << "SHAR_EOF" > 'lsbv_bsr_target.F' module mod_lsbv_bsr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH TRANSPOSE IN 'BSR'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_bsr module procedure ilsbv_bsr module procedure slsbv_bsr module procedure dlsbv_bsr module procedure clsbv_bsr module procedure zlsbv_bsr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_bsr SHAR_EOF fi # end of overwriting check if test -f 'lsbv_coo_target.F' then echo shar: will not over-write existing file "'lsbv_coo_target.F'" else cat << "SHAR_EOF" > 'lsbv_coo_target.F' module mod_lsbv_coo ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'COO'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use mod_hash use representation_of_data use properties implicit none interface lsbv_coo module procedure ilsbv_coo module procedure slsbv_coo module procedure dlsbv_coo module procedure clsbv_coo module procedure zlsbv_coo end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_coo SHAR_EOF fi # end of overwriting check if test -f 'lsbv_csc_target.F' then echo shar: will not over-write existing file "'lsbv_csc_target.F'" else cat << "SHAR_EOF" > 'lsbv_csc_target.F' module mod_lsbv_csc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH TRANSPOSE IN 'CSC'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface lsbv_csc module procedure ilsbv_csc module procedure slsbv_csc module procedure dlsbv_csc module procedure clsbv_csc module procedure zlsbv_csc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_csc SHAR_EOF fi # end of overwriting check if test -f 'lsbv_csr_target.F' then echo shar: will not over-write existing file "'lsbv_csr_target.F'" else cat << "SHAR_EOF" > 'lsbv_csr_target.F' module mod_lsbv_csr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH TRANSPOSE IN 'CSR'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface lsbv_csr module procedure ilsbv_csr module procedure slsbv_csr module procedure dlsbv_csr module procedure clsbv_csr module procedure zlsbv_csr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_csr SHAR_EOF fi # end of overwriting check if test -f 'lsbv_dia_target.F' then echo shar: will not over-write existing file "'lsbv_dia_target.F'" else cat << "SHAR_EOF" > 'lsbv_dia_target.F' module mod_lsbv_dia ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'DIA'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface lsbv_dia module procedure ilsbv_dia module procedure slsbv_dia module procedure dlsbv_dia module procedure clsbv_dia module procedure zlsbv_dia end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_dia SHAR_EOF fi # end of overwriting check if test -f 'lsbv_vbr_target.F' then echo shar: will not over-write existing file "'lsbv_vbr_target.F'" else cat << "SHAR_EOF" > 'lsbv_vbr_target.F' module mod_lsbv_vbr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'VBR'-STORAGE ! lsbv = Left Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface lsbv_vbr module procedure ilsbv_vbr module procedure slsbv_vbr module procedure dlsbv_vbr module procedure clsbv_vbr module procedure zlsbv_vbr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerlsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionlsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionlsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexlsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexlsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_lsbv_vbr SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bco_target.F' then echo shar: will not over-write existing file "'rmbv_bco_target.F'" else cat << "SHAR_EOF" > 'rmbv_bco_target.F' module mod_rmbv_bco ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BCO'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_bco module procedure irmbv_bco module procedure srmbv_bco module procedure drmbv_bco module procedure crmbv_bco module procedure zrmbv_bco end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_bco SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bdi_target.F' then echo shar: will not over-write existing file "'rmbv_bdi_target.F'" else cat << "SHAR_EOF" > 'rmbv_bdi_target.F' module mod_rmbv_bdi ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BDI'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_bdi module procedure irmbv_bdi module procedure srmbv_bdi module procedure drmbv_bdi module procedure crmbv_bdi module procedure zrmbv_bdi end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_bdi SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bsc_target.F' then echo shar: will not over-write existing file "'rmbv_bsc_target.F'" else cat << "SHAR_EOF" > 'rmbv_bsc_target.F' module mod_rmbv_bsc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BSC'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_bsc module procedure irmbv_bsc module procedure srmbv_bsc module procedure drmbv_bsc module procedure crmbv_bsc module procedure zrmbv_bsc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_bsc SHAR_EOF fi # end of overwriting check if test -f 'rmbv_bsr_target.F' then echo shar: will not over-write existing file "'rmbv_bsr_target.F'" else cat << "SHAR_EOF" > 'rmbv_bsr_target.F' module mod_rmbv_bsr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'BSR'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_bsr module procedure irmbv_bsr module procedure srmbv_bsr module procedure drmbv_bsr module procedure crmbv_bsr module procedure zrmbv_bsr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_bsr SHAR_EOF fi # end of overwriting check if test -f 'rmbv_coo_target.F' then echo shar: will not over-write existing file "'rmbv_coo_target.F'" else cat << "SHAR_EOF" > 'rmbv_coo_target.F' module mod_rmbv_coo ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'COO'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties implicit none interface rmbv_coo module procedure irmbv_coo module procedure srmbv_coo module procedure drmbv_coo module procedure crmbv_coo module procedure zrmbv_coo end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_coo SHAR_EOF fi # end of overwriting check if test -f 'rmbv_csc_target.F' then echo shar: will not over-write existing file "'rmbv_csc_target.F'" else cat << "SHAR_EOF" > 'rmbv_csc_target.F' module mod_rmbv_csc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'CSC'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties implicit none interface rmbv_csc module procedure irmbv_csc module procedure srmbv_csc module procedure drmbv_csc module procedure crmbv_csc module procedure zrmbv_csc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_csc SHAR_EOF fi # end of overwriting check if test -f 'rmbv_csr_target.F' then echo shar: will not over-write existing file "'rmbv_csr_target.F'" else cat << "SHAR_EOF" > 'rmbv_csr_target.F' module mod_rmbv_csr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'CSR'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties implicit none interface rmbv_csr module procedure irmbv_csr module procedure srmbv_csr module procedure drmbv_csr module procedure crmbv_csr module procedure zrmbv_csr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_csr SHAR_EOF fi # end of overwriting check if test -f 'rmbv_dia_target.F' then echo shar: will not over-write existing file "'rmbv_dia_target.F'" else cat << "SHAR_EOF" > 'rmbv_dia_target.F' module mod_rmbv_dia ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'DIA'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties implicit none interface rmbv_dia module procedure irmbv_dia module procedure srmbv_dia module procedure drmbv_dia module procedure crmbv_dia module procedure zrmbv_dia end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_dia SHAR_EOF fi # end of overwriting check if test -f 'rmbv_vbr_target.F' then echo shar: will not over-write existing file "'rmbv_vbr_target.F'" else cat << "SHAR_EOF" > 'rmbv_vbr_target.F' module mod_rmbv_vbr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS MV MULT. WITH MATRIX IN 'VBR'-STORAGE ! rmbv = Right Multiplication By Vector: y=Ax ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rmbv_vbr module procedure irmbv_vbr module procedure srmbv_vbr module procedure drmbv_vbr module procedure crmbv_vbr module procedure zrmbv_vbr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrmbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rmbv_vbr SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bco_target.F' then echo shar: will not over-write existing file "'rsbv_bco_target.F'" else cat << "SHAR_EOF" > 'rsbv_bco_target.F' module mod_rsbv_bco ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BCO'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use mod_hash use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_bco module procedure irsbv_bco module procedure srsbv_bco module procedure drsbv_bco module procedure crsbv_bco module procedure zrsbv_bco end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_bco SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bdi_target.F' then echo shar: will not over-write existing file "'rsbv_bdi_target.F'" else cat << "SHAR_EOF" > 'rsbv_bdi_target.F' module mod_rsbv_bdi ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BDI'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_bdi module procedure irsbv_bdi module procedure srsbv_bdi module procedure drsbv_bdi module procedure crsbv_bdi module procedure zrsbv_bdi end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_bdi SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bsc_target.F' then echo shar: will not over-write existing file "'rsbv_bsc_target.F'" else cat << "SHAR_EOF" > 'rsbv_bsc_target.F' module mod_rsbv_bsc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BSC'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_bsc module procedure irsbv_bsc module procedure srsbv_bsc module procedure drsbv_bsc module procedure crsbv_bsc module procedure zrsbv_bsc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_bsc SHAR_EOF fi # end of overwriting check if test -f 'rsbv_bsr_target.F' then echo shar: will not over-write existing file "'rsbv_bsr_target.F'" else cat << "SHAR_EOF" > 'rsbv_bsr_target.F' module mod_rsbv_bsr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'BSR'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_bsr module procedure irsbv_bsr module procedure srsbv_bsr module procedure drsbv_bsr module procedure crsbv_bsr module procedure zrsbv_bsr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_bsr SHAR_EOF fi # end of overwriting check if test -f 'rsbv_coo_target.F' then echo shar: will not over-write existing file "'rsbv_coo_target.F'" else cat << "SHAR_EOF" > 'rsbv_coo_target.F' module mod_rsbv_coo ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'COO'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use mod_hash use representation_of_data use properties implicit none interface rsbv_coo module procedure irsbv_coo module procedure srsbv_coo module procedure drsbv_coo module procedure crsbv_coo module procedure zrsbv_coo end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_coo SHAR_EOF fi # end of overwriting check if test -f 'rsbv_csc_target.F' then echo shar: will not over-write existing file "'rsbv_csc_target.F'" else cat << "SHAR_EOF" > 'rsbv_csc_target.F' module mod_rsbv_csc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'CSC'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface rsbv_csc module procedure irsbv_csc module procedure srsbv_csc module procedure drsbv_csc module procedure crsbv_csc module procedure zrsbv_csc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_csc SHAR_EOF fi # end of overwriting check if test -f 'rsbv_csr_target.F' then echo shar: will not over-write existing file "'rsbv_csr_target.F'" else cat << "SHAR_EOF" > 'rsbv_csr_target.F' module mod_rsbv_csr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'CSR'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface rsbv_csr module procedure irsbv_csr module procedure srsbv_csr module procedure drsbv_csr module procedure crsbv_csr module procedure zrsbv_csr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_csr SHAR_EOF fi # end of overwriting check if test -f 'rsbv_dia_target.F' then echo shar: will not over-write existing file "'rsbv_dia_target.F'" else cat << "SHAR_EOF" > 'rsbv_dia_target.F' module mod_rsbv_dia ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'DIA'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties implicit none interface rsbv_dia module procedure irsbv_dia module procedure srsbv_dia module procedure drsbv_dia module procedure crsbv_dia module procedure zrsbv_dia end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_dia SHAR_EOF fi # end of overwriting check if test -f 'rsbv_vbr_target.F' then echo shar: will not over-write existing file "'rsbv_vbr_target.F'" else cat << "SHAR_EOF" > 'rsbv_vbr_target.F' module mod_rsbv_vbr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : PERFORMS TRI. SOLVE WITH MATRIX IN 'VBR'-STORAGE ! rsbv = Right Solve By Vector ! ********************************************************************** use representation_of_data use properties use mod_dense_mat_algos implicit none interface rsbv_vbr module procedure irsbv_vbr module procedure srsbv_vbr module procedure drsbv_vbr module procedure crsbv_vbr module procedure zrsbv_vbr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerrsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionrsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionrsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexrsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexrsbv_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_rsbv_vbr SHAR_EOF fi # end of overwriting check if test -f 'usaxpy_target.F' then echo shar: will not over-write existing file "'usaxpy_target.F'" else cat << "SHAR_EOF" > 'usaxpy_target.F' module mod_usaxpy use blas_sparse_namedconstants interface usaxpy module procedure iusaxpy module procedure susaxpy module procedure dusaxpy module procedure cusaxpy module procedure zusaxpy end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerusaxpy_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionusaxpy_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionusaxpy_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexusaxpy_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexusaxpy_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_usaxpy SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bdi_target.F' then echo shar: will not over-write existing file "'usconv_bco2bdi_target.F'" else cat << "SHAR_EOF" > 'usconv_bco2bdi_target.F' module mod_usconv_bco2bdi use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bco2bdi(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,BLDA,BNDIAG,mb,kb,lb,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data intrinsic min ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_bco2bdi_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_bco2bdi_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_bco2bdi_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_bco2bdi_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_bco2bdi_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bco2bdi end module mod_usconv_bco2bdi SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bsc_target.F' then echo shar: will not over-write existing file "'usconv_bco2bsc_target.F'" else cat << "SHAR_EOF" > 'usconv_bco2bsc_target.F' module mod_usconv_bco2bsc use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bco2bsc(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,col_dim_in_blocks,col_dim_of_block,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_bco2bsc_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_bco2bsc_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_bco2bsc_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_bco2bsc_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_bco2bsc_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bco2bsc end module mod_usconv_bco2bsc SHAR_EOF fi # end of overwriting check if test -f 'usconv_bco2bsr_target.F' then echo shar: will not over-write existing file "'usconv_bco2bsr_target.F'" else cat << "SHAR_EOF" > 'usconv_bco2bsr_target.F' module mod_usconv_bco2bsr use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bco2bsr(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,row_dim_in_blocks,col_dim_of_block,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_bco2bsr_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_bco2bsr_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_bco2bsr_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_bco2bsr_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_bco2bsr_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bco2bsr end module mod_usconv_bco2bsr SHAR_EOF fi # end of overwriting check if test -f 'usconv_bdi2bco_target.F' then echo shar: will not over-write existing file "'usconv_bdi2bco_target.F'" else cat << "SHAR_EOF" > 'usconv_bdi2bco_target.F' module mod_usconv_bdi2bco use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bdi2bco(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,BLDA,BNNZ,mb,kb,lb,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data intrinsic floor ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_bdi2bco_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_bdi2bco_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_bdi2bco_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_bdi2bco_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_bdi2bco_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bdi2bco end module mod_usconv_bdi2bco SHAR_EOF fi # end of overwriting check if test -f 'usconv_bsc2bco_target.F' then echo shar: will not over-write existing file "'usconv_bsc2bco_target.F'" else cat << "SHAR_EOF" > 'usconv_bsc2bco_target.F' module mod_usconv_bsc2bco use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bsc2bco(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,s,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_bsc2bco_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_bsc2bco_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_bsc2bco_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_bsc2bco_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_bsc2bco_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bsc2bco end module mod_usconv_bsc2bco SHAR_EOF fi # end of overwriting check if test -f 'usconv_bsr2bco_target.F' then echo shar: will not over-write existing file "'usconv_bsr2bco_target.F'" else cat << "SHAR_EOF" > 'usconv_bsr2bco_target.F' module mod_usconv_bsr2bco use properties use mod_conv_tools use representation_of_data contains subroutine usconv_bsr2bco(a,ierr) integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,s,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_bsr2bco_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_bsr2bco_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_bsr2bco_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_bsr2bco_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_bsr2bco_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_bsr2bco end module mod_usconv_bsr2bco SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2csc_target.F' then echo shar: will not over-write existing file "'usconv_coo2csc_target.F'" else cat << "SHAR_EOF" > 'usconv_coo2csc_target.F' module mod_usconv_coo2csc use properties use mod_conv_tools use representation_of_data contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integerusconv_coo2csc_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionusconv_coo2csc_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionusconv_coo2csc_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexusconv_coo2csc_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexusconv_coo2csc_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_usconv_coo2csc SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2csr_target.F' then echo shar: will not over-write existing file "'usconv_coo2csr_target.F'" else cat << "SHAR_EOF" > 'usconv_coo2csr_target.F' module mod_usconv_coo2csr use properties use mod_conv_tools use representation_of_data contains subroutine usconv_coo2csr(a,ierr) implicit none integer,intent(inout) :: a type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer ,intent(inout)::ierr integer :: res,rest ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) !!*************************************************************************** ! ********************************************************************** #include "integerusconv_coo2csr_source.F" case(SSP_MATRIX) !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionusconv_coo2csr_source.F" ! ********************************************************************** !!*************************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_coo2csr_source.F" ! ********************************************************************** !!*************************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_coo2csr_source.F" ! ********************************************************************** !!*************************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_coo2csr_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_coo2csr end module mod_usconv_coo2csr SHAR_EOF fi # end of overwriting check if test -f 'usconv_coo2dia_target.F' then echo shar: will not over-write existing file "'usconv_coo2dia_target.F'" else cat << "SHAR_EOF" > 'usconv_coo2dia_target.F' module mod_usconv_coo2dia use properties use mod_conv_tools use representation_of_data contains subroutine usconv_coo2dia(a,ierr) implicit none integer,intent(inout) :: a type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer ,intent(inout)::ierr integer :: res,LDA,NDIAG,nnz,rest rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_coo2dia_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_coo2dia_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_coo2dia_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_coo2dia_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_coo2dia_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_coo2dia end module mod_usconv_coo2dia SHAR_EOF fi # end of overwriting check if test -f 'usconv_csc2coo_target.F' then echo shar: will not over-write existing file "'usconv_csc2coo_target.F'" else cat << "SHAR_EOF" > 'usconv_csc2coo_target.F' module mod_usconv_csc2coo use properties use mod_conv_tools use representation_of_data contains subroutine usconv_csc2coo(a,ierr) integer,intent(inout) :: a type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer ,intent(inout)::ierr integer :: res,s,rest ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_csc2coo_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_csc2coo_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_csc2coo_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_csc2coo_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_csc2coo_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_csc2coo end module mod_usconv_csc2coo SHAR_EOF fi # end of overwriting check if test -f 'usconv_csr2coo_target.F' then echo shar: will not over-write existing file "'usconv_csr2coo_target.F'" else cat << "SHAR_EOF" > 'usconv_csr2coo_target.F' module mod_usconv_csr2coo use properties use mod_conv_tools use representation_of_data contains subroutine usconv_csr2coo(a,ierr) integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,s,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_csr2coo_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_csr2coo_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_csr2coo_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_csr2coo_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_csr2coo_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_csr2coo end module mod_usconv_csr2coo SHAR_EOF fi # end of overwriting check if test -f 'usconv_dia2coo_target.F' then echo shar: will not over-write existing file "'usconv_dia2coo_target.F'" else cat << "SHAR_EOF" > 'usconv_dia2coo_target.F' module mod_usconv_dia2coo use properties use mod_conv_tools use representation_of_data contains subroutine usconv_dia2coo(a,ierr) implicit none integer,intent(inout) :: a integer ,intent(inout)::ierr integer :: res,LDA,NNZ,rest type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data ierr=-1 rest = modulo(a,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusconv_dia2coo_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusconv_dia2coo_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusconv_dia2coo_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusconv_dia2coo_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusconv_dia2coo_source.F" ! ********************************************************************** case default ierr = blas_error_param return end select end subroutine usconv_dia2coo end module mod_usconv_dia2coo SHAR_EOF fi # end of overwriting check if test -f 'uscr_bco_target.F' then echo shar: will not over-write existing file "'uscr_bco_target.F'" else cat << "SHAR_EOF" > 'uscr_bco_target.F' module mod_uscr_bco ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'BCO'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_bco module procedure iuscr_bco module procedure suscr_bco module procedure duscr_bco module procedure cuscr_bco module procedure zuscr_bco end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_bco_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_bco SHAR_EOF fi # end of overwriting check if test -f 'uscr_bdi_target.F' then echo shar: will not over-write existing file "'uscr_bdi_target.F'" else cat << "SHAR_EOF" > 'uscr_bdi_target.F' module mod_uscr_bdi ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'BDI'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_bdi module procedure iuscr_bdi module procedure suscr_bdi module procedure duscr_bdi module procedure cuscr_bdi module procedure zuscr_bdi end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_bdi_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_bdi SHAR_EOF fi # end of overwriting check if test -f 'uscr_begin_target.F' then echo shar: will not over-write existing file "'uscr_begin_target.F'" else cat << "SHAR_EOF" > 'uscr_begin_target.F' module mod_uscr_begin use mod_INSERTING implicit none contains ! ********************************************************************** ! ! ********************************************************************** # include "integeruscr_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** # include "singlePrecisionuscr_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** # include "doublePrecisionuscr_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_begin SHAR_EOF fi # end of overwriting check if test -f 'uscr_block_begin_target.F' then echo shar: will not over-write existing file "'uscr_block_begin_target.F'" else cat << "SHAR_EOF" > 'uscr_block_begin_target.F' module mod_uscr_block_begin use mod_INSERTING use properties implicit none contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_block_begin SHAR_EOF fi # end of overwriting check if test -f 'uscr_bsc_target.F' then echo shar: will not over-write existing file "'uscr_bsc_target.F'" else cat << "SHAR_EOF" > 'uscr_bsc_target.F' module mod_uscr_bsc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'BSC'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_bsc module procedure iuscr_bsc module procedure suscr_bsc module procedure duscr_bsc module procedure cuscr_bsc module procedure zuscr_bsc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_bsc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_bsc SHAR_EOF fi # end of overwriting check if test -f 'uscr_bsr_target.F' then echo shar: will not over-write existing file "'uscr_bsr_target.F'" else cat << "SHAR_EOF" > 'uscr_bsr_target.F' module mod_uscr_bsr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'BSR'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_bsr module procedure iuscr_bsr module procedure suscr_bsr module procedure duscr_bsr module procedure cuscr_bsr module procedure zuscr_bsr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_bsr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_bsr SHAR_EOF fi # end of overwriting check if test -f 'uscr_coo_target.F' then echo shar: will not over-write existing file "'uscr_coo_target.F'" else cat << "SHAR_EOF" > 'uscr_coo_target.F' module mod_uscr_coo ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'COO'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_coo module procedure iuscr_coo module procedure suscr_coo module procedure duscr_coo module procedure cuscr_coo module procedure zuscr_coo end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_coo_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_coo SHAR_EOF fi # end of overwriting check if test -f 'uscr_csc_target.F' then echo shar: will not over-write existing file "'uscr_csc_target.F'" else cat << "SHAR_EOF" > 'uscr_csc_target.F' module mod_uscr_csc ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'CSC'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_csc module procedure iuscr_csc module procedure suscr_csc module procedure duscr_csc module procedure cuscr_csc module procedure zuscr_csc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_csc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_csc SHAR_EOF fi # end of overwriting check if test -f 'uscr_csr_target.F' then echo shar: will not over-write existing file "'uscr_csr_target.F'" else cat << "SHAR_EOF" > 'uscr_csr_target.F' module mod_uscr_csr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'CSR'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_csr module procedure iuscr_csr module procedure suscr_csr module procedure duscr_csr module procedure cuscr_csr module procedure zuscr_csr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_csr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_csr SHAR_EOF fi # end of overwriting check if test -f 'uscr_dia_target.F' then echo shar: will not over-write existing file "'uscr_dia_target.F'" else cat << "SHAR_EOF" > 'uscr_dia_target.F' module mod_uscr_dia ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'DIA'-FORMAT ! ********************************************************************** use representation_of_data use properties implicit none interface uscr_dia module procedure iuscr_dia module procedure suscr_dia module procedure duscr_dia module procedure cuscr_dia module procedure zuscr_dia end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_dia_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_dia SHAR_EOF fi # end of overwriting check if test -f 'uscr_end_target.F' then echo shar: will not over-write existing file "'uscr_end_target.F'" else cat << "SHAR_EOF" > 'uscr_end_target.F' module mod_uscr_end use mod_INSERTING use mod_INS_ROUTINER use properties contains subroutine uscr_end(a,istat) implicit none integer ,intent(inout)::a,istat integer::prpty,rest,b type(i_matrix),pointer ::ipmatrix type(d_matrix),pointer ::dpmatrix type(s_matrix),pointer ::spmatrix type(c_matrix),pointer ::cpmatrix type(z_matrix),pointer ::zpmatrix b=-a rest = modulo(b,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integeruscr_end_source.F" !!*************************************************************************** ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionuscr_end_source.F" ! ********************************************************************** !!*************************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionuscr_end_source.F" ! ********************************************************************** !!*************************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexuscr_end_source.F" ! ********************************************************************** !!*************************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexuscr_end_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** case default istat = blas_error_param return end select end subroutine uscr_end end module mod_uscr_end SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_block_target.F' then echo shar: will not over-write existing file "'uscr_insert_block_target.F'" else cat << "SHAR_EOF" > 'uscr_insert_block_target.F' module mod_uscr_insert_block use blas_sparse_namedconstants use mod_INSERTING use mod_INS_ROUTINER interface uscr_insert_block module procedure iuscr_insert_block module procedure suscr_insert_block module procedure duscr_insert_block module procedure cuscr_insert_block module procedure zuscr_insert_block end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integeruscr_insert_block_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionuscr_insert_block_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionuscr_insert_block_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexuscr_insert_block_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexuscr_insert_block_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_block SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_clique_target.F' then echo shar: will not over-write existing file "'uscr_insert_clique_target.F'" else cat << "SHAR_EOF" > 'uscr_insert_clique_target.F' module mod_uscr_insert_clique use blas_sparse_namedconstants use mod_uscr_insert_entry interface uscr_insert_clique module procedure iuscr_insert_clique module procedure suscr_insert_clique module procedure duscr_insert_clique module procedure cuscr_insert_clique module procedure zuscr_insert_clique end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integeruscr_insert_clique_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionuscr_insert_clique_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionuscr_insert_clique_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexuscr_insert_clique_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexuscr_insert_clique_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_clique SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_col_target.F' then echo shar: will not over-write existing file "'uscr_insert_col_target.F'" else cat << "SHAR_EOF" > 'uscr_insert_col_target.F' module mod_uscr_insert_col use blas_sparse_namedconstants use mod_uscr_insert_entry interface uscr_insert_col module procedure iuscr_insert_col module procedure suscr_insert_col module procedure duscr_insert_col module procedure cuscr_insert_col module procedure zuscr_insert_col end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integeruscr_insert_col_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionuscr_insert_col_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionuscr_insert_col_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexuscr_insert_col_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexuscr_insert_col_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_col SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_entries_target.F' then echo shar: will not over-write existing file "'uscr_insert_entries_target.F'" else cat << "SHAR_EOF" > 'uscr_insert_entries_target.F' module mod_uscr_insert_entries use blas_sparse_namedconstants use mod_uscr_insert_entry interface uscr_insert_entries module procedure iuscr_insert_entries module procedure suscr_insert_entries module procedure duscr_insert_entries module procedure cuscr_insert_entries module procedure zuscr_insert_entries end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integeruscr_insert_entries_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionuscr_insert_entries_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionuscr_insert_entries_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexuscr_insert_entries_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexuscr_insert_entries_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_entries SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_entry_target.F' then echo shar: will not over-write existing file "'uscr_insert_entry_target.F'" else cat << "SHAR_EOF" > 'uscr_insert_entry_target.F' module mod_uscr_insert_entry use blas_sparse_namedconstants use mod_INSERTING use mod_INS_ROUTINER implicit none interface uscr_insert_entry module procedure iuscr_insert_entry module procedure suscr_insert_entry module procedure duscr_insert_entry module procedure cuscr_insert_entry module procedure zuscr_insert_entry end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integeruscr_insert_entry_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionuscr_insert_entry_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionuscr_insert_entry_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexuscr_insert_entry_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexuscr_insert_entry_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_entry SHAR_EOF fi # end of overwriting check if test -f 'uscr_insert_row_target.F' then echo shar: will not over-write existing file "'uscr_insert_row_target.F'" else cat << "SHAR_EOF" > 'uscr_insert_row_target.F' module mod_uscr_insert_row use blas_sparse_namedconstants use mod_uscr_insert_entry interface uscr_insert_row module procedure iuscr_insert_row module procedure suscr_insert_row module procedure duscr_insert_row module procedure cuscr_insert_row module procedure zuscr_insert_row end interface contains ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "integeruscr_insert_row_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singlePrecisionuscr_insert_row_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doublePrecisionuscr_insert_row_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "singleComplexuscr_insert_row_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** #include "doubleComplexuscr_insert_row_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** end module mod_uscr_insert_row SHAR_EOF fi # end of overwriting check if test -f 'uscr_variable_block_begin_target.F' then echo shar: will not over-write existing file "'uscr_variable_block_begin_target.F'" else cat << "SHAR_EOF" > 'uscr_variable_block_begin_target.F' module mod_uscr_variable_block_begin use mod_INSERTING use properties implicit none contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_variable_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_variable_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_variable_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_variable_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_variable_block_begin_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_variable_block_begin SHAR_EOF fi # end of overwriting check if test -f 'uscr_vbr_target.F' then echo shar: will not over-write existing file "'uscr_vbr_target.F'" else cat << "SHAR_EOF" > 'uscr_vbr_target.F' module mod_uscr_vbr ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : CREATION ROUTINE FOR MATRIX HANDLE FROM 'VBR'-FORMAT ! ********************************************************************** use representation_of_data use properties use mod_usds implicit none interface uscr_vbr module procedure iuscr_vbr module procedure suscr_vbr module procedure duscr_vbr module procedure cuscr_vbr module procedure zuscr_vbr end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integeruscr_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionuscr_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionuscr_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexuscr_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexuscr_vbr_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_uscr_vbr SHAR_EOF fi # end of overwriting check if test -f 'usdot_target.F' then echo shar: will not over-write existing file "'usdot_target.F'" else cat << "SHAR_EOF" > 'usdot_target.F' module mod_usdot use blas_sparse_namedconstants interface usdot module procedure iusdot module procedure susdot module procedure dusdot module procedure cusdot module procedure zusdot end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerusdot_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionusdot_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionusdot_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexusdot_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexusdot_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_usdot SHAR_EOF fi # end of overwriting check if test -f 'usds_target.F' then echo shar: will not over-write existing file "'usds_target.F'" else cat << "SHAR_EOF" > 'usds_target.F' module mod_usds ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : RELEASES HANDLES, LOOKS FOR THE "FREEDOM OF MEMORY" ! ********************************************************************** use representation_of_data use properties implicit none contains subroutine usds(nmb,ierr) implicit none intrinsic modulo integer, intent(in) :: nmb integer, intent(out) :: ierr type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data integer :: rest,val rest = modulo(nmb,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerusds_source.F" ! ********************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionusds_source.F" ! ********************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionusds_source.F" ! ********************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexusds_source.F" ! ********************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexusds_source.F" ! ********************************************************************** case default ierr = blas_error_param end select if (ierr.ne.0) then ierr = blas_error_param return end if end subroutine usds end module mod_usds SHAR_EOF fi # end of overwriting check if test -f 'usga_target.F' then echo shar: will not over-write existing file "'usga_target.F'" else cat << "SHAR_EOF" > 'usga_target.F' module mod_usga use blas_sparse_namedconstants interface usga module procedure iusga module procedure susga module procedure dusga module procedure cusga module procedure zusga end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerusga_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionusga_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionusga_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexusga_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexusga_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_usga SHAR_EOF fi # end of overwriting check if test -f 'usgp_target.F' then echo shar: will not over-write existing file "'usgp_target.F'" else cat << "SHAR_EOF" > 'usgp_target.F' module mod_usgp use mod_INSERTING use properties use representation_of_data contains subroutine usgp (a,pname,m) implicit none integer ,intent(in)::a integer,intent(out)::m integer,intent(in)::pname type(ispmat),pointer :: isp_data type(sspmat),pointer :: ssp_data type(dspmat),pointer :: dsp_data type(cspmat),pointer :: csp_data type(zspmat),pointer :: zsp_data type(i_matrix),pointer :: imatrix type(s_matrix),pointer :: smatrix type(d_matrix),pointer :: dmatrix type(c_matrix),pointer :: cmatrix type(z_matrix),pointer :: zmatrix integer ::rest,ierr character ::test rest = modulo(a,no_of_types) select case(rest) ! ********************************************************************** ! ! ********************************************************************** case(ISP_MATRIX) #include "integerusgp_source.F" ! ********************************************************************** ! ! ********************************************************************** case(SSP_MATRIX) #include "singlePrecisionusgp_source.F" ! ********************************************************************** ! ! ********************************************************************** case(DSP_MATRIX) #include "doublePrecisionusgp_source.F" ! ********************************************************************** ! ! ********************************************************************** case(CSP_MATRIX) #include "singleComplexusgp_source.F" ! ********************************************************************** ! ! ********************************************************************** case(ZSP_MATRIX) #include "doubleComplexusgp_source.F" ! ********************************************************************** ! ! ********************************************************************** case default return end select end subroutine usgp end module mod_usgp SHAR_EOF fi # end of overwriting check if test -f 'usgz_target.F' then echo shar: will not over-write existing file "'usgz_target.F'" else cat << "SHAR_EOF" > 'usgz_target.F' module mod_usgz use mod_usga use blas_sparse_namedconstants interface usgz module procedure iusgz module procedure susgz module procedure dusgz module procedure cusgz module procedure zusgz end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerusgz_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionusgz_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionusgz_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexusgz_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexusgz_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_usgz SHAR_EOF fi # end of overwriting check if test -f 'usmm_target.F' then echo shar: will not over-write existing file "'usmm_target.F'" else cat << "SHAR_EOF" > 'usmm_target.F' module mod_usmm ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : MM MULTIPLICATION, CHOOSES APPROPRIATE SUBROUTINES ! ********************************************************************** use representation_of_data use properties use mod_mbv implicit none interface usmm module procedure iusmm module procedure susmm module procedure dusmm module procedure cusmm module procedure zusmm end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerusmm_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionusmm_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionusmm_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexusmm_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexusmm_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_usmm SHAR_EOF fi # end of overwriting check if test -f 'usmv_target.F' then echo shar: will not over-write existing file "'usmv_target.F'" else cat << "SHAR_EOF" > 'usmv_target.F' module mod_usmv ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : MV MULTIPLICATION, CHOOSES APPROPRIATE SUBROUTINES ! ********************************************************************** use representation_of_data use properties use mod_mbv implicit none interface usmv module procedure iusmv module procedure susmv module procedure dusmv module procedure cusmv module procedure zusmv end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerusmv_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionusmv_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionusmv_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexusmv_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexusmv_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_usmv SHAR_EOF fi # end of overwriting check if test -f 'ussc_target.F' then echo shar: will not over-write existing file "'ussc_target.F'" else cat << "SHAR_EOF" > 'ussc_target.F' module mod_ussc use blas_sparse_namedconstants interface ussc module procedure iussc module procedure sussc module procedure dussc module procedure cussc module procedure zussc end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerussc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionussc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionussc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexussc_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexussc_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_ussc SHAR_EOF fi # end of overwriting check if test -f 'ussm_target.F' then echo shar: will not over-write existing file "'ussm_target.F'" else cat << "SHAR_EOF" > 'ussm_target.F' module mod_ussm ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : TRI. SOLVE, CHOOSES APPROPRIATE SUBROUTINES ! ********************************************************************** use representation_of_data use properties use mod_sbv implicit none interface ussm module procedure iussm module procedure sussm module procedure dussm module procedure cussm module procedure zussm end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerussm_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionussm_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionussm_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexussm_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexussm_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_ussm SHAR_EOF fi # end of overwriting check if test -f 'ussp_target.F' then echo shar: will not over-write existing file "'ussp_target.F'" else cat << "SHAR_EOF" > 'ussp_target.F' module mod_ussp use mod_INSERTING use properties contains subroutine ussp(a,m,istat) implicit none integer ,intent(inout)::a integer,intent(in)::m integer, intent(out)::istat integer::b,rest type(i_matrix),pointer ::ipmatrix type(d_matrix),pointer ::dpmatrix type(s_matrix),pointer ::spmatrix type(c_matrix),pointer ::cpmatrix type(z_matrix),pointer ::zpmatrix b=-a istat = 0 rest = modulo(b,no_of_types) select case(rest) case(ISP_MATRIX) ! ********************************************************************** #include "integerussp_source.F" ! ********************************************************************** !!*************************************************************************** case(SSP_MATRIX) ! ********************************************************************** #include "singlePrecisionussp_source.F" ! ********************************************************************** !!*************************************************************************** case(DSP_MATRIX) ! ********************************************************************** #include "doublePrecisionussp_source.F" ! ********************************************************************** !!*************************************************************************** case(CSP_MATRIX) ! ********************************************************************** #include "singleComplexussp_source.F" ! ********************************************************************** !!*************************************************************************** case(ZSP_MATRIX) ! ********************************************************************** #include "doubleComplexussp_source.F" ! ********************************************************************** !!*************************************************************************** ! ********************************************************************** case default istat = blas_error_param return end select end subroutine ussp end module mod_ussp SHAR_EOF fi # end of overwriting check if test -f 'ussv_target.F' then echo shar: will not over-write existing file "'ussv_target.F'" else cat << "SHAR_EOF" > 'ussv_target.F' module mod_ussv ! ********************************************************************** ! Author : C. Voemel ! ! Date of last modification : 7.7.00 ! ! Description : TRI. SOLVE, CHOOSES APPROPRIATE SUBROUTINES ! ********************************************************************** use representation_of_data use properties use mod_sbv implicit none interface ussv module procedure iussv module procedure sussv module procedure dussv module procedure cussv module procedure zussv end interface contains ! ********************************************************************** ! ! ********************************************************************** #include "integerussv_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singlePrecisionussv_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doublePrecisionussv_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "singleComplexussv_source.F" ! ********************************************************************** ! ! ********************************************************************** #include "doubleComplexussv_source.F" ! ********************************************************************** ! ! ********************************************************************** end module mod_ussv SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'TESTER' then mkdir 'TESTER' fi cd 'TESTER' if test -f 'Makefile.AIX' then echo shar: will not over-write existing file "'Makefile.AIX'" else cat << "SHAR_EOF" > 'Makefile.AIX' FFLAGS = -g # #Place of Sparse BLAS objects SB_LIB = -L../SOFTWARE -lSparseBLAS_AIX #Place of Sparse BLAS modules SB_INCL = -I../SOFTWARE #Place of numeric libraries SYS_LIB = # FC = f90 LD = $(FC) RM = rm -f # MOD_SUF = mod ############################################################################### EXEC_F = test_all # OBJS = test_parameters.o main_all.o ############################################################################### EXEC_F: $(OBJS) $(LD) -o $(EXEC_F) $(LDFLAGS) $(OBJS) $(SB_LIB) ############################################################################### main_all.o: ../SOFTWARE/libSparseBLAS_AIX.a test_parameters.o power_method: ../SOFTWARE/libSparseBLAS_AIX.a power.o $(LD) -o power_method $(LDFLAGS) power.o $(SYS_LIB) $(SB_LIB) ############################################################################### .SUFFIXES: .o .F .c .f .f90 .f90.o : $(FC) $(SB_INCL) -c $*.f90 clean : $(RM) *.o *.$(MOD_SUF) $(EXEC_F) power_method SHAR_EOF fi # end of overwriting check if test -f 'Makefile.ALPHA' then echo shar: will not over-write existing file "'Makefile.ALPHA'" else cat << "SHAR_EOF" > 'Makefile.ALPHA' FFLAGS = -g # #Place of Sparse BLAS objects SB_LIB = -L../SOFTWARE -lSparseBLAS_ALPHA #Place of Sparse BLAS modules SB_INCL = -I../SOFTWARE #Place of numeric libraries SYS_LIB = # FC = f90 LD = $(FC) RM = rm -f # MOD_SUF = mod ############################################################################### EXEC_F = test_all # OBJS = test_parameters.o main_all.o ############################################################################### EXEC_F: $(OBJS) $(LD) -o $(EXEC_F) $(LDFLAGS) $(OBJS) $(SB_LIB) ############################################################################### main_all.o: ../SOFTWARE/libSparseBLAS_ALPHA.a test_parameters.o power_method: ../SOFTWARE/libSparseBLAS_ALPHA.a power.o $(LD) -o power_method $(LDFLAGS) power.o $(SYS_LIB) $(SB_LIB) ############################################################################### .SUFFIXES: .o .F .c .f .f90 .f90.o : $(FC) $(SB_INCL) -c $*.f90 clean : $(RM) *.o *.$(MOD_SUF) $(EXEC_F) power_method SHAR_EOF fi # end of overwriting check if test -f 'Makefile.CRAY' then echo shar: will not over-write existing file "'Makefile.CRAY'" else cat << "SHAR_EOF" > 'Makefile.CRAY' FFLAGS = -g # #Place of Sparse BLAS objects SB_LIB = -L../SOFTWARE -lSparseBLAS_CRAY #Place of Sparse BLAS modules SB_INCL = -p ../SOFTWARE #Place of numeric libraries SYS_LIB = # FC = f90 LD = $(FC) RM = rm -f # MOD_SUF = mod ############################################################################### EXEC_F = test_all # OBJS = test_parameters.o main_all.o ############################################################################### EXEC_F: $(OBJS) $(LD) -o $(EXEC_F) $(LDFLAGS) $(OBJS) $(SB_LIB) ############################################################################### main_all.o: ../SOFTWARE/libSparseBLAS_CRAY.a test_parameters.o power_method: ../SOFTWARE/libSparseBLAS_CRAY.a power.o $(LD) -o power_method $(LDFLAGS) power.o $(SYS_LIB) $(SB_LIB) ############################################################################### .SUFFIXES: .o .F .c .f .f90 .f90.o : $(FC) $(SB_INCL) -c $*.f90 clean : $(RM) *.o *.$(MOD_SUF) $(EXEC_F) power_method SHAR_EOF fi # end of overwriting check if test -f 'Makefile.HP' then echo shar: will not over-write existing file "'Makefile.HP'" else cat << "SHAR_EOF" > 'Makefile.HP' FFLAGS = -g # #Place of Sparse BLAS objects SB_LIB = -L../SOFTWARE -lSparseBLAS_HP #Place of Sparse BLAS modules SB_INCL = -I../SOFTWARE #Place of numeric libraries SYS_LIB = # FC = f90 LD = $(FC) RM = rm -f # MOD_SUF = mod ############################################################################### EXEC_F = test_all # OBJS = test_parameters.o main_all.o ############################################################################### EXEC_F: $(OBJS) $(LD) -o $(EXEC_F) $(LDFLAGS) $(OBJS) $(SB_LIB) ############################################################################### main_all.o: ../SOFTWARE/libSparseBLAS_HP.a test_parameters.o power_method: ../SOFTWARE/libSparseBLAS_HP.a power.o $(LD) -o power_method $(LDFLAGS) power.o $(SYS_LIB) $(SB_LIB) ############################################################################### .SUFFIXES: .o .F .c .f .f90 .f90.o : $(FC) $(SB_INCL) -c $*.f90 clean : $(RM) *.o *.$(MOD_SUF) $(EXEC_F) power_method SHAR_EOF fi # end of overwriting check if test -f 'Makefile.NAG' then echo shar: will not over-write existing file "'Makefile.NAG'" else cat << "SHAR_EOF" > 'Makefile.NAG' FFLAGS = -g # #Place of Sparse BLAS objects SB_LIB = -L../SOFTWARE -lSparseBLAS_NAG #Place of Sparse BLAS modules SB_INCL = -I../SOFTWARE #Place of numeric libraries SYS_LIB = # FC = f90 LD = $(FC) RM = rm -f # MOD_SUF = mod ############################################################################### EXEC_F = test_all # OBJS = test_parameters.o main_all.o ############################################################################### EXEC_F: $(OBJS) $(LD) -o $(EXEC_F) $(LDFLAGS) $(OBJS) $(SB_LIB) ############################################################################### main_all.o: ../SOFTWARE/libSparseBLAS_NAG.a test_parameters.o power_method: ../SOFTWARE/libSparseBLAS_NAG.a power.o $(LD) -o power_method $(LDFLAGS) power.o $(SYS_LIB) $(SB_LIB) ############################################################################### .SUFFIXES: .o .F .c .f .f90 .f90.o : $(FC) $(SB_INCL) -c $*.f90 clean : $(RM) *.o *.$(MOD_SUF) $(EXEC_F) power_method SHAR_EOF fi # end of overwriting check if test -f 'Makefile.SGI' then echo shar: will not over-write existing file "'Makefile.SGI'" else cat << "SHAR_EOF" > 'Makefile.SGI' FFLAGS = -g # #Place of Sparse BLAS objects SB_LIB = -L../SOFTWARE -lSparseBLAS_SGI #Place of Sparse BLAS modules SB_INCL = -I../SOFTWARE #Place of numeric libraries SYS_LIB = -lscs -lfastm # FC = f90 LD = $(FC) RM = rm -f # MOD_SUF = mod ############################################################################### EXEC_F = test_all # OBJS = test_parameters.o main_all.o ############################################################################### EXEC_F: $(OBJS) $(LD) -o $(EXEC_F) $(LDFLAGS) $(OBJS) $(SB_LIB) ############################################################################### main_all.o: ../SOFTWARE/libSparseBLAS_SGI.a test_parameters.o power_method: ../SOFTWARE/libSparseBLAS_SGI.a power.o $(LD) -o power_method $(LDFLAGS) power.o $(SYS_LIB) $(SB_LIB) ############################################################################### .SUFFIXES: .o .F .c .f .f90 .f90.o : $(FC) $(SB_INCL) -c $*.f90 clean : $(RM) *.o *.$(MOD_SUF) $(EXEC_F) power_method SHAR_EOF fi # end of overwriting check if test -f 'Makefile.SUN' then echo shar: will not over-write existing file "'Makefile.SUN'" else cat << "SHAR_EOF" > 'Makefile.SUN' FFLAGS = -g # #Place of Sparse BLAS objects SB_LIB = -L../SOFTWARE -lSparseBLAS_SUN #Place of Sparse BLAS modules SB_INCL = -M../SOFTWARE #Place of numeric libraries SYS_LIB = # FC = f90 LD = $(FC) RM = rm -f # MOD_SUF = mod ############################################################################### EXEC_F = test_all # OBJS = test_parameters.o main_all.o ############################################################################### EXEC_F: $(OBJS) $(LD) -o $(EXEC_F) $(LDFLAGS) $(OBJS) $(SB_LIB) ############################################################################### main_all.o: ../SOFTWARE/libSparseBLAS_SUN.a test_parameters.o power_method: ../SOFTWARE/libSparseBLAS_SUN.a power.o $(LD) -o power_method $(LDFLAGS) power.o $(SYS_LIB) $(SB_LIB) ############################################################################### .SUFFIXES: .o .F .c .f .f90 .f90.o : $(FC) $(SB_INCL) -c $*.f90 clean : $(RM) *.o *.$(MOD_SUF) $(EXEC_F) power_method SHAR_EOF fi # end of overwriting check if test -f 'main_all.f90' then echo shar: will not over-write existing file "'main_all.f90'" else cat << "SHAR_EOF" > 'main_all.f90' program tester use blas_sparse use mod_test_parameters real(kind=dp), dimension(:), allocatable :: x,y,z real(kind=dp), dimension(:,:), allocatable :: dense_C, dense_B complex(kind=dp), dimension(:), allocatable :: xc,yc,zc complex(kind=dp), dimension(:,:), allocatable :: densec_C, densec_B integer, dimension(:), allocatable :: x_i,y_i,z_i integer :: i, prpty, a,d,ierr,b,c,dt,istat integer :: n, nnz integer,parameter::conj=1 integer :: USE_MATRIX = T_MATRIX integer, parameter :: INDEX_BASE = blas_one_base integer, parameter :: BLOCK_INTERN = blas_col_major n = 5 nnz = 14 ! ********************************************************************** print *,'*********************************************************' if(conj.eq.0) then d=usdot(x_dot,indx_dot,y_dot) else d=usdot(x_dot,indx_dot,y_dot,conj) end if write(*,*) 'Testing USDOT' write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(d - res_usdot) print *,'*********************************************************' if(alpha.eq.0) then call usaxpy(x_axpy,indx_axpy,y_axpy) else call usaxpy(x_axpy,indx_axpy,y_axpy,alpha) end if write(*,*) 'Testing USAXPY' write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(y_axpy - res_usaxpy) print *,'*********************************************************' call usga(y_ga,x_ga,indx_ga) write(*,*) 'Testing USGA' write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(x_ga - res_usga) print *,'*********************************************************' call usgz(y_gz,x_gz,indx_gz) write(*,*) 'Testing USGZ' write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(x_gz - res_usgz_x) write(*,*) 'Error : ',abs(y_gz - res_usgz_y) print *,'*********************************************************' call ussc(x_sc,y_sc,indx_sc) write(*,*) 'Testing USSC' write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(y_sc - res_ussc) ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX A' prpty = blas_general + INDEX_BASE allocate(x(5),y(5)) y=0. call duscr_begin(A_m,A_n,a,istat) call ussp(a,prpty,istat) do i=1,size(A_val) call uscr_insert_entry(a,A_val(i),A_indx(i),A_jndx(i),istat) end do call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Ax) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Ax),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if print *,'*********************************************************' print *,'TEST WITH MATRIX A_SU' prpty = blas_symmetric + INDEX_BASE + blas_upper allocate(x(5),y(5)) y=0. call duscr_begin(A_SU_m,A_SU_n,c,istat) call ussp(c,prpty,istat) call uscr_insert_clique(c,A_SU,A_SU_indx,A_SU_jndx,istat) call uscr_end(c,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(c,x,y,istat) write(*,*) 'Error : ',abs(y-A_SUx) write(*,*) '* Test of MM multiplication *' call usmm(c,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-A_SUx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(c, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if print *,'*********************************************************' print *,'TEST WITH MATRIX A_SU' prpty = blas_symmetric + INDEX_BASE + blas_lower allocate(x(5),y(5)) y=0. call duscr_begin(A_SL_m,A_SL_n,a,istat) call ussp(a,prpty,istat) call uscr_insert_col(a,1,A_SL_1,A_SL_1_INDX,istat) call uscr_insert_col(a,2,A_SL_2,A_SL_2_INDX,istat) call uscr_insert_col(a,3,A_SL_3,A_SL_3_INDX,istat) call uscr_insert_col(a,4,A_SL_4,A_SL_4_INDX,istat) call uscr_insert_col(a,5,A_SL_5,A_SL_5_INDX,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-A_SLx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-A_SLx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX B' prpty = blas_general + INDEX_BASE allocate(x(5),y(3)) y=0. call duscr_begin(B_m,B_n,b,istat) call ussp(b,prpty,istat) call uscr_insert_row(b,1,B_1,B_1_JNDX,istat) call uscr_insert_row(b,2,B_2,B_2_JNDX,istat) call uscr_insert_row(b,3,B_3,B_3_JNDX,istat) call uscr_end(b,istat ) !call print(b,istat) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(b,x,y,istat) write(*,*) 'Error : ',abs(y-Bx) write(*,*) '* Test of MM multiplication *' call usmm(b,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Bx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(b, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX C' USE_MATRIX = O_MATRIX prpty = blas_general + INDEX_BASE allocate(xc(3),yc(3)) call zuscr_begin(C_m,C_n,a,istat) call ussp(a,prpty,istat) call uscr_insert_entries(a,VAL_C,INDX_C,JNDX_C,istat) call uscr_end(a,istat ) do i=1,size(xc) xc(i) = (1.,1.) end do allocate(zc(size(xc))) zc = xc yc = (0.,0.) allocate(densec_C(size(yc),3),densec_B(size(xc),3)) do i = 1,3 densec_B(:,i) = xc densec_C(:,i) = (0.,0.) end do write(*,*) '* Test of MV multiplication *' select case(USE_MATRIX) case (O_MATRIX) call usmv(a,xc,yc,istat) case (T_MATRIX) call usmv(a,xc,yc,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call usmv(a,xc,yc,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform MV multiplication' stop end if write(*,*) 'Errors of computed solution: ' if(USE_MATRIX.eq.O_MATRIX) then write(*,*) 'Error : ',abs(yc-Cx) else if(USE_MATRIX.eq.T_MATRIX) then write(*,*) 'Error : ',abs(yc-CTx) else if(USE_MATRIX.eq.H_MATRIX) then write(*,*) 'Error : ',abs(yc-CHx) end if write(*,*) '* Test of MM multiplication *' select case(USE_MATRIX) case (O_MATRIX) call usmm(a,densec_B,densec_C,istat) case (T_MATRIX) call usmm(a,densec_B,densec_C,istat, transa =& & TRANSP_MATRIX) case (H_MATRIX) call usmm(a,densec_B,densec_C,istat, transa =& & HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform MM multiplication' stop end if write(*,*) 'Errors of computed solution: ' if(USE_MATRIX.eq.O_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-Cx),i=1,3) else if(USE_MATRIX.eq.T_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-CTx),i=1,3) else if(USE_MATRIX.eq.H_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-CHx),i=1,3) end if write(*,*) '*****************************' write(*,*) '* Deleting matrix handle *' call usds(a,istat) deallocate(xc,yc,zc,densec_C,densec_B) ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX D' USE_MATRIX = O_MATRIX prpty = blas_general + INDEX_BASE allocate(xc(3),yc(3)) call zuscr_begin(d_m,d_n,a,istat) call ussp(a,prpty,istat) call uscr_insert_entries(a,VAL_d,INDX_d,JNDX_d,istat) call uscr_end(a,istat ) do i=1,size(xc) xc(i) = (1.,1.) end do allocate(zc(size(xc))) zc = xc yc = (0.,0.) allocate(densec_C(size(yc),3),densec_B(size(xc),3)) do i = 1,3 densec_B(:,i) = xc densec_C(:,i) = (0.,0.) end do write(*,*) '* Test of MV multiplication *' select case(USE_MATRIX) case (O_MATRIX) call usmv(a,xc,yc,istat) case (T_MATRIX) call usmv(a,xc,yc,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call usmv(a,xc,yc,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform MV multiplication' stop end if write(*,*) 'Errors of computed solution: ' if(USE_MATRIX.eq.O_MATRIX) then write(*,*) 'Error : ',abs(yc-dx) else if(USE_MATRIX.eq.T_MATRIX) then write(*,*) 'Error : ',abs(yc-dTx) else if(USE_MATRIX.eq.H_MATRIX) then write(*,*) 'Error : ',abs(yc-dHx) end if write(*,*) '* Test of MM multiplication *' select case(USE_MATRIX) case (O_MATRIX) call usmm(a,densec_B,densec_C,istat) case (T_MATRIX) call usmm(a,densec_B,densec_C,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call usmm(a,densec_B,densec_C,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform MM multiplication' stop end if write(*,*) 'Errors of computed solution: ' if(USE_MATRIX.eq.O_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-dx),i=1,3) else if(USE_MATRIX.eq.T_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-dTx),i=1,3) else if(USE_MATRIX.eq.H_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-dHx),i=1,3) end if write(*,*) '*****************************' write(*,*) '* Deleting matrix handle *' call usds(a,istat) deallocate(xc,yc,zc,densec_C,densec_B) print *,'*****************************************************& &****' print *,'TEST WITH MATRIX DT' USE_MATRIX = O_MATRIX prpty = blas_upper_triangular + INDEX_BASE allocate(xc(3),yc(3)) call zuscr_begin(DT_m,DT_n,dt,istat) call ussp(dt,prpty,istat) call uscr_insert_entries(dt,VAL_DT,INDX_DT,JNDX_DT,istat) call uscr_end(dt,istat ) do i=1,size(xc) xc(i) = (1.,1.) end do allocate(zc(size(xc))) zc = xc yc = (0.,0.) allocate(densec_C(size(yc),3),densec_B(size(xc),3)) do i = 1,3 densec_B(:,i) = xc densec_C(:,i) = (0.,0.) end do write(*,*) '* Test of MV multiplication *' select case(USE_MATRIX) case (O_MATRIX) call usmv(dt,xc,yc,istat) case (T_MATRIX) call usmv(dt,xc,yc,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call usmv(dt,xc,yc,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform MV multiplication' stop end if write(*,*) 'Errors of computed solution: ' if(USE_MATRIX.eq.O_MATRIX) then write(*,*) 'Error : ',abs(yc-DTTx) else if(USE_MATRIX.eq.T_MATRIX) then write(*,*) 'Error : ',abs(yc-DTTx) else if(USE_MATRIX.eq.H_MATRIX) then write(*,*) 'Error : ',abs(yc-DTHx) end if write(*,*) '* Test of MM multiplication *' select case(USE_MATRIX) case (O_MATRIX) call usmm(dt,densec_B,densec_C,istat) case (T_MATRIX) call usmm(dt,densec_B,densec_C,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call usmm(dt,densec_B,densec_C,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform MM multiplication' stop end if write(*,*) 'Errors of computed solution: ' if(USE_MATRIX.eq.O_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-DTTx),i=1,3) else if(USE_MATRIX.eq.T_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-DTTx),i=1,3) else if(USE_MATRIX.eq.H_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-DTHx),i=1,3) end if write(*,*) '* Test of tri. vec. solver *' select case(USE_MATRIX) case (O_MATRIX) call ussv(dt,yc,istat) case (T_MATRIX) call ussv(dt,yc,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call ussv(dt,yc,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform triangular solve' stop else write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(yc-xc) end if write(*,*) '* Testing tri. mat. solver *' select case(USE_MATRIX) case (O_MATRIX) call ussm(dt,densec_C,istat) case (T_MATRIX) call ussm(dt,densec_C,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call ussm(dt,densec_C,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform triangular solve' stop else write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(densec_C-densec_B) end if write(*,*) '*****************************' write(*,*) '* Deleting matrix handle *' call usds(dt,istat) deallocate(xc,yc,zc,densec_C,densec_B) print *,'*********************************************************' print *,'TEST WITH MATRIX DH' USE_MATRIX = O_MATRIX prpty = blas_hermitian + blas_upper + INDEX_BASE allocate(xc(3),yc(3)) call zuscr_begin(DT_m,DT_n,dt,istat) call ussp(dt,prpty,istat) call uscr_insert_entries(dt,VAL_DT,INDX_DT,JNDX_DT,istat) call uscr_end(dt,istat ) do i=1,size(xc) xc(i) = (1.,1.) end do allocate(zc(size(xc))) zc = xc yc = (0.,0.) allocate(densec_C(size(yc),3),densec_B(size(xc),3)) do i = 1,3 densec_B(:,i) = xc densec_C(:,i) = (0.,0.) end do write(*,*) '* Test of MV multiplication *' select case(USE_MATRIX) case (O_MATRIX) call usmv(dt,xc,yc,istat) case (T_MATRIX) call usmv(dt,xc,yc,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call usmv(dt,xc,yc,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform MV multiplication' stop end if write(*,*) 'Errors of computed solution: ' if(USE_MATRIX.eq.O_MATRIX) then write(*,*) 'Error : ',abs(yc-dx) else if(USE_MATRIX.eq.T_MATRIX) then write(*,*) 'Error : ',abs(yc-DTHx) else if(USE_MATRIX.eq.H_MATRIX) then write(*,*) 'Error : ',abs(yc-DTHx) end if write(*,*) '* Test of MM multiplication *' select case(USE_MATRIX) case (O_MATRIX) call usmm(dt,densec_B,densec_C,istat) case (T_MATRIX) call usmm(dt,densec_B,densec_C,istat, transa = TRANSP_MATRIX) case (H_MATRIX) call usmm(dt,densec_B,densec_C,istat, transa = HERMIT_MATRIX) case default stop 'No valid choice' end select if (istat.ne.0) then write(*,*) 'Can''t perform MM multiplication' stop end if write(*,*) 'Errors of computed solution: ' if(USE_MATRIX.eq.O_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-dx),i=1,3) else if(USE_MATRIX.eq.T_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-DTHx),i=1,3) else if(USE_MATRIX.eq.H_MATRIX) then write(*,*) 'Error : ',(abs(densec_C(:,i)-DTHx),i=1,3) end if write(*,*) '*****************************' write(*,*) '* Deleting matrix handle *' call usds(dt,istat) deallocate(xc,yc,zc,densec_C,densec_B) ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX I' prpty = blas_general + INDEX_BASE allocate(x_i(5),y_i(5)) y_i=0 call iuscr_begin(I_m,I_n,a,istat) call ussp(a,prpty,istat) do i=1,size(I_val) call uscr_insert_entry(a,I_val(i),I_indx(i),I_jndx(i),istat) end do call uscr_end(a,istat ) do i=1,size(x_i) x_i(i) = int(i) end do allocate(z_i(size(x_i))) z_i = x_i write(*,*) '* Test of MV multiplication *' call usmv(a,x_i,y_i,istat) write(*,*) 'Error : ',abs(y_i-Ix) write(*,*) '* Deleting matrix handle *' deallocate(x_i,y_i,z_i) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX J' prpty = blas_upper_triangular + INDEX_BASE allocate(x_i(5),y_i(5)) y_i=0 call iuscr_begin(J_m,J_n,a,istat) call uscr_insert_entries(a,J_VAL,J_indx,J_jndx,istat) call ussp(a,prpty,istat) call uscr_end(a,istat ) do i=1,size(x_i) x_i(i) = int(i) end do allocate(z_i(size(x_i))) z_i = x_i write(*,*) '* Test of MV multiplication *' call usmv(a,x_i,y_i,istat) write(*,*) 'Error : ',abs(y_i-Jx) write(*,*) '* Test of tri. vec. solver *' call ussv(a,y_i,istat) if (istat.ne.0) then write(*,*) 'Can''t perform triangular solve' stop else write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(y_i-x_i) end if write(*,*) '* Deleting matrix handle *' deallocate(x_i,y_i,z_i) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX M' prpty = blas_upper_triangular + INDEX_BASE + BLOCK_INTERN allocate(x(4),y(4)) y=0. call duscr_block_begin(M_Mb,M_Nb,M_k,M_l,a,istat) call ussp(a,prpty,istat) call uscr_insert_block(a,M11,1,1,istat) call uscr_insert_block(a,M12,1,2,istat) call uscr_insert_block(a,M22,2,2,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Mx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Mx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX N' prpty = blas_lower_triangular + INDEX_BASE + BLOCK_INTERN allocate(x(4),y(4)) y=0. call duscr_block_begin(N_Mb,N_Nb,N_k,N_l,a,istat) call ussp(a,prpty,istat) call uscr_insert_block(a,N11,1,1,istat) call uscr_insert_block(a,N21,2,1,istat) call uscr_insert_block(a,N22,2,2,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Nx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Nx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX T' prpty = blas_upper_triangular + INDEX_BASE allocate(x(5),y(5)) y=0. call duscr_begin(T_m,T_n,a,istat) call uscr_insert_entries(a,T_VAL,T_indx,T_jndx,istat) call ussp(a,prpty,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Tx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Tx),i=1,3) write(*,*) '* Test of tri. vec. solver *' call ussv(a,y,istat) if (istat.ne.0) then write(*,*) 'Can''t perform triangular solve' stop else write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(y-x) end if write(*,*) '* Testing tri. mat. solver *' call ussm(a,dense_C,istat) if (istat.ne.0) then write(*,*) 'Can''t perform triangular solve' stop else write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(dense_C-dense_B) end if write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX U' prpty = blas_lower_triangular + INDEX_BASE allocate(x(5),y(5)) y=0. call duscr_begin(U_m,U_n,a,istat) call ussp(a,prpty,istat) call uscr_insert_entries(a,U_VAL,U_indx,U_jndx,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Ux) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Ux),i=1,3) write(*,*) '* Test of tri. vec. solver *' call ussv(a,y,istat) if (istat.ne.0) then write(*,*) 'Can''t perform triangular solve' stop else write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(y-x) end if write(*,*) '* Testing tri. mat. solver *' call ussm(a,dense_C,istat) if (istat.ne.0) then write(*,*) 'Can''t perform triangular solve' stop else write(*,*) 'Errors of computed solution: ' write(*,*) 'Error : ',abs(dense_C-dense_B) end if write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX X' prpty = blas_general + INDEX_BASE + BLOCK_INTERN allocate(x(8),y(6)) y=0. call duscr_block_begin(X_Mb,X_Nb,X_k,X_l,a,istat) call ussp(a,prpty,istat) call uscr_insert_block(a,X11,1,1,istat) call uscr_insert_block(a,X31,3,1,istat) call uscr_insert_block(a,X22,2,2,istat) call uscr_insert_block(a,X13,1,3,istat) call uscr_insert_block(a,X23,2,3,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Xx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Xx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX Y' prpty = blas_general + INDEX_BASE + BLOCK_INTERN allocate(x(6),y(6)) y=0. call duscr_block_begin(Y_Mb,Y_Nb,Y_k,Y_l,a,istat) call ussp(a,prpty,istat) call uscr_insert_block(a,Y11,1,1,istat) call uscr_insert_block(a,Y12,1,2,istat) call uscr_insert_block(a,Y22,2,2,istat) call uscr_insert_block(a,Y21,2,1,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Yx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Yx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if print *,'*********************************************************' print *,'TEST WITH MATRIX Y_SU' prpty = blas_symmetric + INDEX_BASE+blas_upper+BLOCK_INTERN allocate(x(6),y(6)) y=0. call duscr_block_begin(Y_SU_Mb,Y_SU_Nb,Y_SU_k,Y_SU_l,a,istat) call ussp(a,prpty,istat) call uscr_insert_block(a,Y_SU11,1,1,istat) call uscr_insert_block(a,Y_SU12,1,2,istat) call uscr_insert_block(a,Y_SU22,2,2,istat) call uscr_insert_block(a,Y_SU21,2,1,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Y_SUx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Y_SUx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if print *,'*********************************************************' print *,'TEST WITH MATRIX Y_SL' prpty = blas_symmetric + INDEX_BASE+blas_lower+BLOCK_INTERN allocate(x(6),y(6)) y=0. call duscr_block_begin(Y_SL_Mb,Y_SL_Nb,Y_SL_k,Y_SL_l,a,istat) call ussp(a,prpty,istat) call uscr_insert_block(a,Y_SL11,1,1,istat) call uscr_insert_block(a,Y_SL12,1,2,istat) call uscr_insert_block(a,Y_SL22,2,2,istat) call uscr_insert_block(a,Y_SL21,2,1,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Y_SLx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Y_SLx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** print *,'*********************************************************' print *,'TEST WITH MATRIX Z' prpty = blas_general + INDEX_BASE + BLOCK_INTERN allocate(x(11),y(11)) y=0. call duscr_variable_block_begin(Z_Mb,Z_Nb,Z_kk,Z_ll,a,istat) call ussp(a,prpty,istat) call uscr_insert_block(a,Z11,1,1,istat) call uscr_insert_block(a,Z13,1,3,istat) call uscr_insert_block(a,Z22,2,2,istat) call uscr_insert_block(a,Z32,3,2,istat) call uscr_insert_block(a,Z23,2,3,istat) call uscr_insert_block(a,Z31,3,1,istat) call uscr_insert_block(a,Z33,3,3,istat) call uscr_insert_block(a,Z55,5,5,istat) call uscr_insert_block(a,Z44,4,4,istat) call uscr_insert_block(a,Z51,5,1,istat) call uscr_insert_block(a,Z15,1,5,istat) call uscr_insert_block(a,Z34,3,4,istat) call uscr_insert_block(a,Z43,4,3,istat) call uscr_end(a,istat ) do i=1,size(x) x(i) = dble(i) end do allocate(z(size(x))) z = x allocate(dense_C(size(y),3),dense_B(size(x),3)) do i = 1,3 dense_B(:,i) = x dense_C(:,i) = 0. end do write(*,*) '* Test of MV multiplication *' call usmv(a,x,y,istat) write(*,*) 'Error : ',abs(y-Zx) write(*,*) '* Test of MM multiplication *' call usmm(a,dense_B,dense_C,istat) write(*,*) 'Error : ',(abs(dense_C(:,i)-Zx),i=1,3) write(*,*) '* Deleting matrix handle *' deallocate(x,y,dense_C,dense_B,z) call usds(a, istat) if (istat.ne.0) then write(*,*) 'Deallocation failure' stop end if ! ********************************************************************** write(*,*) '*****************************' write(*,*) '* REGULAR END OF PROGRAM *' write(*,*) '*****************************' ierr=0 end program tester SHAR_EOF fi # end of overwriting check if test -f 'power.f90' then echo shar: will not over-write existing file "'power.f90'" else cat << "SHAR_EOF" > 'power.f90' PROGRAM MAIN_POWER ! Purpose: Build sparse matrix and ! perform power iteration via calls to Sparse BLAS ! Header file of prototypes and named constants USE BLAS_SPARSE INTEGER, PARAMETER :: NMAX = 4, NNZ = 6 INTEGER A,I,N,NITERS,ISTAT INTEGER, DIMENSION(:), ALLOCATABLE :: INDX,JNDX REAL(KIND=DP), DIMENSION(:), ALLOCATABLE :: VAL,Q,WORK REAL(KIND=DP) LAMBDA ALLOCATE (VAL(NNZ),INDX(NNZ),JNDX(NNZ)) ALLOCATE (Q(NMAX),WORK(NMAX)) ! ----------------------------------- ! Define matrix, in coordinate format ! ----------------------------------- VAL = (/ 1.1_dp, 2.2_dp, 2.4_dp, 3.3_dp, 4.1_dp, 4.4_dp/) INDX = (/ 1, 2, 2, 3, 4, 4/) JNDX = (/ 1, 2, 4, 3, 1, 4/) N = NMAX ! ---------------------------------- ! Step 1: Create Sparse BLAS handle ! ---------------------------------- CALL DUSCR_BEGIN( N, N, A, ISTAT) ! ----------------------------------- ! Step 2: Insert entries all at once ! ----------------------------------- CALL USCR_INSERT_ENTRIES(A, VAL, INDX, JNDX, ISTAT) ! ----------------------------------------------- ! Step 3: Complete construction of sparse matrix ! ----------------------------------------------- CALL USCR_END(A, ISTAT) ! ----------------------------------------------- ! Step 4: Call Power Method Routine ! ----------------------------------------------- ! q - eigenvector approximation. ! lambda - eigenvalue approximation. NITERS = 100 CALL POWER_METHOD(A, Q, LAMBDA, N, NITERS, WORK, ISTAT) IF (ISTAT.NE.0) THEN WRITE(*,*) 'ERROR IN POWER_METHOD = ',ISTAT ELSE WRITE(*,*) 'NUMBER OF ITERATIONS = ',NITERS WRITE(*,*) 'APPROXIMATE DOMINANT EIGENVALUE = ',LAMBDA ENDIF ! ----------------------------------------------- ! Step 5: Release Matrix Handle ! ----------------------------------------------- CALL USDS(A,ISTAT) CONTAINS SUBROUTINE POWER_METHOD(A, Q, LAMBDA, N, NITERS, Z, ISTAT) USE BLAS_SPARSE IMPLICIT NONE REAL(KIND=DP), DIMENSION(:),INTENT(INOUT) :: Q(N),Z(N) REAL(KIND=DP), INTENT(OUT) :: LAMBDA INTEGER, INTENT(IN) :: A,N,NITERS INTEGER, INTENT(OUT):: ISTAT INTEGER I,ITER,ISEED REAL(KIND=DP):: NORMZ REAL Y INTRINSIC RANDOM_NUMBER,DOT_PRODUCT ! Fill Z by random numbers DO I = 1, N CALL RANDOM_NUMBER(HARVEST=Y) Z(I)=DBLE(Y) END DO DO ITER = 1, NITERS !Compute 2-norm of Z NORMZ = SQRT(DOT_PRODUCT(Z(1:N),Z(1:N))) !Normalize Z if (NORMZ.NE.0) Z(1:N) = Z(1:N)/NORMZ !Copy Z to Q Q=Z !Set Z to 0 Z=0.D0 !Compute new Z CALL USMV(A, Q, Z, ISTAT) !Test error flag IF (ISTAT.NE.0) RETURN !New LAMBDA LAMBDA = DOT_PRODUCT(Q,Z) END DO RETURN END SUBROUTINE POWER_METHOD END PROGRAM MAIN_POWER SHAR_EOF fi # end of overwriting check if test -f 'test_parameters.f90' then echo shar: will not over-write existing file "'test_parameters.f90'" else cat << "SHAR_EOF" > 'test_parameters.f90' module mod_test_parameters use blas_sparse_namedconstants use properties ! *** The test matrices integer, parameter :: MATRIX_A = 1 integer, parameter :: MATRIX_A_SU = 2 integer, parameter :: MATRIX_A_SL = 3 integer, parameter :: MATRIX_T = 4 integer, parameter :: MATRIX_U = 5 integer, parameter :: MATRIX_B = 6 integer, parameter :: MATRIX_X = 7 integer, parameter :: MATRIX_Y = 8 integer, parameter :: MATRIX_Y_SU = 9 integer, parameter :: MATRIX_Y_SL = 10 integer, parameter :: MATRIX_M = 11 integer, parameter :: MATRIX_N = 12 integer, parameter :: MATRIX_Z = 13 integer, parameter :: MATRIX_C = 14 integer, parameter :: MATRIX_I = 15 integer, parameter :: MATRIX_J = 16 ! *** Which functionality of MV/MM mult./Tri solve should be called ? integer, parameter :: O_MATRIX = 0 !original integer, parameter :: T_MATRIX = 1 !transpose integer, parameter :: H_MATRIX = 2 !hermit ! *** Level 1 routines real(kind=dp),dimension(3)::x_dot=(/1.,3.,5./) real(kind=dp),dimension(6)::y_dot=(/2.,4.,6.,8.,10.,12./) integer ,dimension(3),parameter ::indx_dot=(/2,3,4/) real(kind=dp),dimension(3)::x_axpy=(/51.,53.,55./) real(kind=dp),dimension(6)::y_axpy=(/52.,54.,56.,58.,60.,62./) integer ,dimension(3)::indx_axpy=(/2,3,4/) real(kind=dp),parameter::alpha=2. real(kind=dp),dimension(3)::x_ga=(/31.,33.,35./) real(kind=dp),dimension(6)::y_ga=(/32.,34.,36.,38.,40.,42./) integer ,dimension(3)::indx_ga=(/2,3,4/) real(kind=dp),dimension(3)::x_gz=(/11.,13.,15./) real(kind=dp),dimension(6)::y_gz=(/12.,14.,16.,18.,20.,22./) integer ,dimension(3) ::indx_gz=(/2,3,4/) real(kind=dp),dimension(3)::x_sc=(/41.,43.,45./) real(kind=dp),dimension(6)::y_sc=(/42.,44.,46.,48.,50.,52./) integer ,dimension(3) ::indx_sc=(/2,3,4/) complex(kind=dp),dimension(3)::xc_dot=(/(1.,1.),(3.,1.),(5.,1.)/) complex(kind=dp),dimension(6)::yc_dot=(/(2.,1.),(4.,1.),(6.,1.),(8.,1.),(10.,1.),(12.,1.)/) integer ,dimension(3),parameter ::indxc_dot=(/2,3,4/) complex(kind=dp),dimension(3)::xc_axpy=(/(51.,1.),(53.,1.),(55.,1.)/) complex(kind=dp),dimension(6)::yc_axpy=(/(52.,1.),(54.,1.),(56.,1.),(58.,1.),(60.,1.),(62.,1.)/) integer ,dimension(3)::indxc_axpy=(/2,3,4/) complex(kind=dp),parameter::alphac=(2.,1) complex(kind=dp),dimension(3)::xc_ga=(/(31.,1.),(33.,1.),(35.,1.)/) complex(kind=dp),dimension(6)::yc_ga=(/(32.,1.),(34.,1.),(36.,1.),(38.,1.),(40.,1.),(42.,1.)/) integer ,dimension(3)::indxc_ga=(/2,3,4/) complex(kind=dp),dimension(3)::xc_gz=(/(11.,1.),(13.,1.),(15.,1.)/) complex(kind=dp),dimension(6)::yc_gz=(/(12.,1.),(14.,1.),(16.,1.),(18.,1.),(20.,1.),(22.,1.)/) integer ,dimension(3) ::indxc_gz=(/2,3,4/) complex(kind=dp),dimension(3)::xc_sc=(/(41.,1.),(43.,1.),(45.,1.)/) complex(kind=dp),dimension(6)::yc_sc=(/(42.,1.),(44.,1.),(46.,1.),(48.,1.),(50.,1.),(52.,1.)/) integer ,dimension(3) ::indxc_sc=(/2,3,4/) ! *** Level 2,3 and handle management routines !----------------------------------------------------------------- ! Test - Matrices : ! ! /11 0 13 14 0\ /11 0 13 14 0\ /11 0 31 41 51\ ! | 0 0 23 24 0| | 0 0 23 24 0| | 0 0 32 42 52| ! A= |31 32 33 34 0|A_SU=|13 23 33 34 0|A_SL=|31 32 33 0 0| ! | 0 42 0 44 0| |14 24 0 44 0| |41 42 0 44 0| ! \51 52 0 0 55/ \ 0 0 0 0 55/ \51 52 0 0 55/ ! ! / 1 4 7 10 13\ ! B= | 2 5 8 11 14| ! \ 3 6 9 12 15/ ! ! / 1 i\ ! C= | | ! \-i 1/ ! ! / 1 i\ ! D= | | ! \-i 1/ ! ! I = A (integer storage) ! ! J = T (integer storage) ! ! / 1 2 | 4 7 \ / 1 0 | \ ! | 0 3 | 5 8 | | 2 5 | | ! M= |-------+-------| N= |-------+------| ! | | 6 9 | | 3 6 | 8 0 | ! \ | 0 10 / \ 4 7 | 9 10 / ! ! / 1 1 1 1 1\ / 1 \ ! | 1 1 1 1| | 1 1 | ! T= | 1 1 1| U=| 1 1 1 | ! | 1 | | 1 1 1 1 | ! \ 1/ \ 1 1 1 1/ ! ! /11 12 | 0 0 | 15 16| 0 0\ ! |21 22 | 0 0 | 25 26| 0 0| ! |------+-------+------+------| ! X= | 0 0 | 33 0 | 35 36| 0 0| ! | 0 0 | 43 44 | 45 46| 0 0| ! |------+-------+------+------| ! |51 52 | 0 0 | 0 0| 0 0| ! \61 62 | 0 0 | 0 0| 0 0/ ! ! / 1 3 | 5 7 | 0 0\ ! | 3 4 | 6 8 | 0 0| ! |------+-------+------| ! Y= | 9 11 | 13 15 | 0 0| ! |10 12 | 15 16 | 0 0| ! |------+-------+------| ! | 0 0 | 0 0 | 0 0| ! \ 0 0 | 0 0 | 0 0/ ! ! / 4 2 | 0 0 0 | 1 | 0 0 0 | -1 1 \ ! | 1 5 | 0 0 0 | 2 | 0 0 0 | 0 -1 | ! |------+----------+----+----------+-------| ! | 0 0 | 6 1 2 | 2 | 0 0 0 | 0 0 | ! | 1 5 | 2 7 1 | 0 | 0 0 0 | 0 0 | ! | 1 5 | -1 2 9 | 3 | 0 0 0 | 0 0 | ! |------+----------+----+----------+-------| ! Z= | 2 1 | 3 4 5 | 10 | 4 3 2 | 0 0 | ! |------+----------+----+----------+-------| ! | 0 0 | 0 0 0 | 4 | 13 4 2 | 0 0 | ! | 0 0 | 0 0 0 | 3 | 3 11 3 | 0 0 | ! | 0 0 | 0 0 0 | 0 | 2 0 7 | 0 0 | ! |------+----------+----+----------+-------| ! | 8 4 | 0 0 0 | 0 | 0 0 0 | 25 3 | ! \-2 3 | 0 0 0 | 0 | 0 0 0 | 8 12 / ! !----------------------------------------------------------------- !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! /11 0 13 14 0\ ! | 0 0 23 24 0| ! A= |31 32 33 34 0| ! | 0 42 0 44 0| ! \51 52 0 0 55/ ! real(kind=dp), dimension(14) ::& A_val=(/ 11.,51.,31.,32.,34.,52.,13.,23.,33.,14.,24.,42.,55.,44. /) integer, dimension(14) ::& A_indx= (/ 1,5,3,3,3,5,1,2,3,1,2,4,5,4 /) integer, dimension(14) ::& A_jndx = (/ 1,1,1,2,4,2,3,3,3,4,4,2,5,4 /) integer ::A_m=5 integer ::A_n=5 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! /11 0 31 0 51\ ! | 0 0 32 42 52| ! A_SL=|31 32 33 0 0| ! | 0 42 0 44 0| ! \51 52 0 0 55/ ! real(kind=dp),dimension(5) ::A_SL_1=(/ 11., 0.,31., 0.,51./) integer,dimension(5) ::A_SL_1_INDX=(/1,2,3,4,5/) real(kind=dp),dimension(5) ::A_SL_2=(/0., 0.,32., 42., 52./) integer,dimension(5) ::A_SL_2_INDX=(/1,2,3,4,5/) real(kind=dp),dimension(5) ::A_SL_3=(/31.,32.,33., 0.,0./) integer,dimension(5) ::A_SL_3_INDX=(/1,2,3,4,5/) real(kind=dp),dimension(5) ::A_SL_4=(/0.,42.,0., 44.,0./) integer,dimension(5) ::A_SL_4_INDX=(/1,2,3,4,5/) real(kind=dp),dimension(5) ::A_SL_5=(/51.,52.,0., 0.,55./) integer,dimension(5) ::A_SL_5_INDX=(/1,2,3,4,5/) integer ::A_SL_m=5 integer,parameter::A_SL_n=5 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! /11 0 13 14 0\ ! | 0 0 23 24 0| !A_SU=|13 23 33 34 0| ! |14 24 0 44 0| ! \ 0 0 0 0 55/ real(kind=dp),dimension(5,5),parameter::& A_SU=reshape((/11.,0.,0.,0.,0.,0.,0.,0.,0.,0.,13.,23.,33.,0.,0.,14.,24.,34.,44.,0.,0.,0.,0.,0.,55./),shape=(/5,5/)) integer,dimension(5) ::A_SU_indx=(/1,2,3,4,5/) integer,dimension(5) ::A_SU_jndx=(/1,2,3,4,5/) integer,parameter::A_SU_m=5 integer,parameter::A_SU_n=5 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 4 7 10 13\ ! B= | 2 5 8 11 14| ! \ 3 6 9 12 15/ ! real(kind=dp),dimension(5) ::B_1=(/ 1.,4.,7.,10.,13./) integer,dimension(5) ::B_1_JNDX=(/1,2,3,4,5/) real(kind=dp),dimension(5) ::B_2=(/2.,5.,8.,11.,14./) integer,dimension(5) ::B_2_JNDX=(/1,2,3,4,5/) real(kind=dp),dimension(5) ::B_3=(/3., 6.,9.,12.,15./) integer,dimension(5) ::B_3_JNDX=(/1,2,3,4,5/) integer ::B_m=3 integer ::B_n=5 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 0 i\ !C= | 0 0 0 | ! \-i 0 1/ complex(kind=dp),dimension(4),parameter ::VAL_C=(/(1.,0.),(0.,1.),(0.,-1.),(1.,0.)/) integer ,dimension(4) ::INDX_C=(/1,1,3,3/) integer ,dimension(4) ::JNDX_C=(/1,3,1,3/) integer,parameter::C_m=3 integer,parameter::C_n=3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 -i -i\ !D= | i 1 -i | ! \ i i 1 / complex(kind=dp),dimension(9),parameter ::VAL_d=(/(1.,0.),(0.,-1.),(0.,-1.),(0.,1.),(1.,0.),(0.,-1.),(0.,1.),(0.,1.),(1.,0.)/) integer ,dimension(9) ::INDX_d=(/1,1,1,2,2,2,3,3,3/) integer ,dimension(9) ::JNDX_d=(/1,2,3,1,2,3,1,2,3/) integer,parameter::d_m=3 integer,parameter::d_n=3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 -i -i \ !DT= | 1 -i | ! \ 1 / complex(kind=dp),dimension(6),parameter ::VAL_DT=(/(1.,0.),(0.,-1.),(0.,-1.),(1.,0.),(0.,-1.),(1.,0.)/) integer ,dimension(6) ::INDX_DT=(/1,1,1,2,2,3/) integer ,dimension(6) ::JNDX_DT=(/1,2,3,2,3,3/) integer,parameter::DT_m=3 integer,parameter::DT_N=3 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! /11 0 13 14 0\ ! | 0 0 23 24 0| ! I= |31 32 33 34 0| ! | 0 42 0 44 0| ! \51 52 0 0 55/ ! integer, dimension(14) ::& I_val=(/ 11,51,31,32,34,52,13,23,33,14,24,42,55,44 /) integer, dimension(14) ::& I_indx= (/ 1,5,3,3,3,5,1,2,3,1,2,4,5,4 /) integer, dimension(14) ::& I_jndx = (/ 1,1,1,2,4,2,3,3,3,4,4,2,5,4 /) integer ::I_m=5 integer ::I_n=5 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 1 1 1 1\ ! | 1 1 1 1| ! J= | 1 1 1| ! | 1 | ! \ 1/ ! integer,dimension(14) ::J_VAL=1 integer,dimension(14) ::J_indx=(/1,1,2,1,2,3,1,2,3,4,1,2,3,5/) integer,dimension(14) ::J_jndx=(/1,2,2,3,3,3,4,4,4,4,5,5,5,5/) integer,parameter::J_m=5 integer,parameter::J_n=5 integer,parameter::J_nz=14 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 2 | 4 7 \ ! | 0 3 | 5 8 | ! M= |-------+-------| ! | | 6 9 | ! \ | 0 10 / real(kind=dp),dimension(2,2), parameter::& M11=reshape((/1,0,2,3/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter::& M12=reshape((/4,5,7,8/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & M22=reshape((/6,0,9,10/),shape=(/2,2/)) integer,parameter::M_Mb=2 integer,parameter::M_Nb=2 integer,parameter::M_k=2 integer,parameter::M_l=2 ! !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 0 | \ ! | 2 5 | | ! N= |-------+------| ! | 3 6 | 8 0 | ! \ 4 7 | 9 10 / real(kind=dp),dimension(2,2), parameter::& N11=reshape((/1,2,0,5/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter::& N21=reshape((/3,4,6,7/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & N22=reshape((/8,9,0,10/),shape=(/2,2/)) integer,parameter::N_Mb=2 integer,parameter::N_Nb=2 integer,parameter::N_k=2 integer,parameter::N_l=2 ! !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 1 1 1 1\ ! | 1 1 1 1| ! T= | 1 1 1| ! | 1 | ! \ 1/ ! real(kind=dp),dimension(14) ::T_VAL=1. integer,dimension(14) ::T_indx=(/1,1,2,1,2,3,1,2,3,4,1,2,3,5/) integer,dimension(14) ::T_jndx=(/1,2,2,3,3,3,4,4,4,4,5,5,5,5/) integer,parameter::T_m=5 integer,parameter::T_n=5 integer,parameter::T_nz=14 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 \ ! | 1 1 | ! U=| 1 1 1 | ! | 1 1 1 1 | ! \ 1 1 1 1/ real(kind=dp),dimension(14) ::U_VAL=1. integer,dimension(14) ::U_jndx=(/1,1,2,1,2,3,1,2,3,4,1,2,3,5/) integer,dimension(14) ::U_indx=(/1,2,2,3,3,3,4,4,4,4,5,5,5,5/) integer,parameter::U_m=5 integer,parameter::U_n=5 integer,parameter::U_nz=14 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! /11 12 | 0 0 | 15 16| 0 0\ ! |21 22 | 0 0 | 25 26| 0 0| ! |------+-------+------+------| ! X= | 0 0 | 33 0 | 35 36| 0 0| ! | 0 0 | 43 44 | 45 46| 0 0| ! |------+-------+------+------| ! |51 52 | 0 0 | 0 0| 0 0| ! \61 62 | 0 0 | 0 0| 0 0/ real(kind=dp),dimension(2,2), parameter::& X11=reshape((/11,21,12,22/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter::& X31=reshape((/51,61,52,62/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & X22=reshape((/33,43,0,44/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & X13=reshape((/15,25,16,26/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & X23=reshape((/35,45,36,46/),shape=(/2,2/)) integer,parameter::X_Mb=3 integer,parameter::X_Nb=4 integer,parameter::X_k=2 integer,parameter::X_l=2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 3 | 5 7 | 0 0\ ! | 3 4 | 6 8 | 0 0| ! |------+-------+------| ! Y= | 9 11 | 13 15 | 0 0| ! |10 12 | 15 16 | 0 0| ! |------+-------+------| ! | 0 0 | 0 0 | 0 0| ! \ 0 0 | 0 0 | 0 0/ real(kind=dp),dimension(2,2), parameter::& Y11=reshape((/1,3,3,4/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter::& Y21=reshape((/9,10,11,12/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Y12=reshape((/5,6,7,8/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Y22=reshape((/13,15,15,16/),shape=(/2,2/)) integer,parameter::Y_Mb=3 integer,parameter::Y_Nb=3 integer,parameter::Y_k=2 integer,parameter::Y_l=2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 3 | 5 7 | 0 0\ ! | 3 4 | 6 8 | 0 0| ! |------+-------+------| ! Y_SU= | 5 6 | 13 15 | 0 0| ! | 7 8 | 15 16 | 0 0| ! |------+-------+------| ! | 0 0 | 0 0 | 0 0| ! \ 0 0 | 0 0 | 0 0/ real(kind=dp),dimension(2,2), parameter::& Y_SU11=reshape((/1,3,3,4/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter::& Y_SU21=reshape((/5,7,6,8/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Y_SU12=reshape((/5,6,7,8/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Y_SU22=reshape((/13,15,15,16/),shape=(/2,2/)) integer,parameter::Y_SU_Mb=3 integer,parameter::Y_SU_Nb=3 integer,parameter::Y_SU_k=2 integer,parameter::Y_SU_l=2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! / 1 3 | 9 10 | 0 0\ ! | 3 4 | 11 12 | 0 0| ! |------+-------+------| !Y_SL= | 9 11 | 13 15 | 0 0| ! |10 12 | 15 16 | 0 0| ! |------+-------+------| ! | 0 0 | 0 0 | 0 0| ! \ 0 0 | 0 0 | 0 0/ real(kind=dp),dimension(2,2), parameter::& Y_SL11=reshape((/1,3,3,4/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter::& Y_SL21=reshape((/9,10,11,12/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Y_SL12=reshape((/9,11,10,12/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Y_SL22=reshape((/13,15,15,16/),shape=(/2,2/)) integer,parameter::Y_SL_Mb=3 integer,parameter::Y_SL_Nb=3 integer,parameter::Y_SL_k=2 integer,parameter::Y_SL_l=2 !&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& ! test for Variable blocks ! ! / 4 2 | 0 0 0 | 1 | 0 0 0 | -1 1 \ ! | 1 5 | 0 0 0 | 2 | 0 0 0 | 0 -1 | ! |------+----------+----+----------+-------| ! | 0 0 | 6 1 2 | 2 | 0 0 0 | 0 0 | ! | 1 5 | 2 7 1 | 0 | 0 0 0 | 0 0 | ! | 1 5 | -1 2 9 | 3 | 0 0 0 | 0 0 | ! |------+----------+----+----------+-------| ! Z= | 2 1 | 3 4 5 | 10 | 4 3 2 | 0 0 | ! |------+----------+----+----------+-------| ! | 0 0 | 0 0 0 | 4 | 13 4 2 | 0 0 | ! | 0 0 | 0 0 0 | 3 | 3 11 3 | 0 0 | ! | 0 0 | 0 0 0 | 0 | 2 0 7 | 0 0 | ! |------+----------+----+----------+-------| ! | 8 4 | 0 0 0 | 0 | 0 0 0 | 25 3 | ! \-2 3 | 0 0 0 | 0 | 0 0 0 | 8 12 / ! !----------------------------------------------------------------- real(kind=dp),dimension(2,2), parameter::& Z11=reshape((/4.0,1.0,2.0,5.0/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Z15=reshape((/-1.0,0.0,1.0,-1.0/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Z55=reshape((/25.0,8.0,3.0,12.0/),shape=(/2,2/)) real(kind=dp),dimension(2,2), parameter:: & Z51=reshape((/8.0,-2.0,4.0,3.0/),shape=(/2,2/)) real(kind=dp),dimension(3,3), parameter:: & Z22=reshape((/6.0,2.0,-1.0,1.0,7.0,2.0,2.0,1.0,9.0/),shape=(/3,3/)) real(kind=dp),dimension(3,3), parameter:: & Z44=reshape((/13.0,3.0,2.0,4.0,11.0,0.0,2.0,3.0,7.0/),shape=(/3,3/)) real(kind=dp),dimension(2,1), parameter:: & Z13=reshape((/1.0,2.0/),shape=(/2,1/)) real(kind=dp),dimension(1,3), parameter ::& Z32=reshape((/3.0,4.0,5.0/),shape=(/1,3/)) real(kind=dp),dimension(1,3), parameter ::& Z34=reshape((/4.0,3.0,2.0/),shape=(/1,3/)) real(kind=dp),dimension(3,1), parameter ::& Z43=reshape((/4.0,3.0,0.0/),shape=(/3,1/)) real(kind=dp),dimension(3,1), parameter ::& Z23=reshape((/2.0,0.0,3.0/),shape=(/3,1/)) real(kind=dp),dimension(1,2), parameter ::& Z31=reshape((/2.0,1.0/),shape=(/1,2/)) real(kind=dp),dimension(1,1), parameter ::& Z33=reshape((/10.0/),shape=(/1,1/)) integer ,dimension(5) ::Z_kk=(/2,3,1,3,2/) integer ,dimension(5) ::Z_ll=(/2,3,1,3,2/) integer,parameter::Z_Mb=5 integer,parameter::Z_Nb=5 !---------------------------------------------------! ! Test - Results for multiplication with x(i)=dbl(i)! !---------------------------------------------------! real(kind=dp) :: res_usdot = 62. real(kind=dp) :: res_usaxpy(6) =(/52.,156.,162.,168.,60.,62./) real(kind=dp) :: res_usga(3) =(/34.,36.,38./) real(kind=dp) :: res_usgz_x(3)=(/14.,16.,18./) real(kind=dp) :: res_usgz_y(6)=(/12.,0.,0.,0.,20.,22./) real(kind=dp) :: res_ussc(6)=(/42.,41.,43.,45.,50.,52./) complex(kind=dp) :: resc_usdot=(65.,-9.) complex(kind=dp) :: resc_usaxpy(6) =(/(52.,1.),(155.,54.),(161.,56.),(167.,58.),(60.,1.),(62.,1.)/) complex(kind=dp) :: resc_usga(3) =(/(34.,1.),(36.,1.),(38.,1.)/) complex(kind=dp) :: resc_usgz_x(3)=(/(14.,1.),(16.,1.),(18.,1.)/) complex(kind=dp) :: resc_usgz_y(6)=(/(12.,1.),(0.,0.),(0.,0.),(0.,0.),(20.,1.),(22.,1.)/) complex(kind=dp) :: resc_ussc(6)=(/(42.,1.),(41.,1.),(43.,1.),(45.,1.),(50.,1.),(52.,1.)/) real(kind=dp) :: Ax(5) =(/106.,165.,330.,260.,430./) real(kind=dp) :: A_SUx(5)= (/106.,165.,294.,340.,275./) real(kind=dp) :: A_SLx(5) = (/359.,524.,194.,260.,430./) real(kind=dp) :: ATx(5) = (/359.,524.,158.,340.,275./) real(kind=dp) :: AT_SLx(5) = (/106.,165.,294.,340.,275./) real(kind=dp) :: AT_SUx(5) = (/359.,524.,194.,260.,430./) real(kind=dp) :: Bx(3) = (/ 135.,150.,165. /) real(kind=dp) :: BTx(5) = (/14.,32.,50.,68.,86./) real(kind=dp) :: Mx(4) = (/ 45.,53.,54.,40./) real(kind=dp) :: MTx(4) = (/1.,8.,32.,90./) real(kind=dp) :: Nx(4) = (/ 1.,12.,39.,85./) real(kind=dp) :: NTx(4) = (/30.,56.,60.,40./) real(kind=dp) :: Tx(5) =(/15.,14.,12.,4.,5./) real(kind=dp) :: TTx(5) = (/ 1.,3.,6.,10.,11. /) real(kind=dp) :: Ux(5) = (/ 1.,3.,6.,10.,11. /) real(kind=dp) :: UTx(5) = (/15.,14.,12.,4.,5./) real(kind=dp) :: Xx(6) = (/206.,346.,490.,806.,155.,185./) real(kind=dp) :: XTx(8) = (/674.,688.,271.,176.,350.,360.,0.,0./) real(kind=dp) :: Yx(6) = (/50.,61.,130.,143.,0.,0./) real(kind=dp) :: YTx(6) = (/74.,92.,116.,132.,0.,0./) real(kind=dp) :: Y_SUx(6) = (/50.,61.,116.,132.,0.,0./) real(kind=dp) :: Y_SLx(6) = (/74.,92.,130.,143.,0.,0./) real(kind=dp) :: Zx(11) = (/15.,12.,44.,39.,68.,184.,165.,154.,77.,299.,216./) real(kind=dp) :: ZTx(11) = (/76.,91.,39.,65.,85.,138.,157.,134.,113.,337.,161./) complex(kind=dp) :: Cx(3) =(/(0.,2.),(0.,0.),(2.,0.)/) complex(kind=dp) :: CTx(3)=(/(0.,2.),(0.,0.),(2.,0.)/) complex(kind=dp) :: CHx(3)=(/(0.,2.),(0.,0.),(2.,0.)/) complex(kind=dp) :: dx(3) =(/(3.,-1.),(1.,1.),(-1.,3.)/) complex(kind=dp) :: dTx(3)=(/(0.,2.),(0.,0.),(2.,0.)/) complex(kind=dp) :: dHx(3)=(/(0.,2.),(0.,0.),(2.,0.)/) complex(kind=dp) :: DTTx(3) =(/(3.,-1.),(2.,0.),(1.,1.)/) complex(kind=dp) :: DTHx(3) =(/(3.,-1.),(1.,1.),(-1.,3.)/) integer :: Ix(5) =(/106,165,330,260,430/) integer :: Jx(5) =(/15,14,12,4,5/) end module mod_test_parameters SHAR_EOF fi # end of overwriting check cd .. # End of shell archive exit 0