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((p