diff --git a/base/serial/Makefile b/base/serial/Makefile index ded3bb17a..9fe0a285b 100644 --- a/base/serial/Makefile +++ b/base/serial/Makefile @@ -5,54 +5,12 @@ FOBJS = psb_lsame.o \ psb_ssymbmm.o psb_dsymbmm.o psb_csymbmm.o psb_zsymbmm.o \ psb_snumbmm.o psb_dnumbmm.o psb_cnumbmm.o psb_znumbmm.o \ psb_srwextd.o psb_drwextd.o psb_crwextd.o psb_zrwextd.o -# psb_regen_mod.o psb_lsame.o psb_zspgetrow.o\ -# psb_zcsmm.o psb_zcsmv.o psb_zspgtdiag.o psb_zspgtblk.o\ -# psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zspcnv.o\ -# psb_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.o \ -# psb_zcoins.o psb_zcsprt.o psb_zneigh.o psb_ztransp.o psb_ztransc.o\ -# psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspscal.o psb_zspclip.o\ -# psb_getifield.o psb_setifield.o psb_update_mod.o psb_getrow_mod.o\ -# psb_zgelp.o\ -# psb_zspshift.o psb_zspsetbld.o\ -# psb_ccsprt.o psb_cspcnv.o psb_ccoins.o psb_ccsnmi.o\ -# psb_cfixcoo.o psb_cipcsr2coo.o psb_cipcoo2csr.o psb_cipcoo2csc.o \ -# psb_cgelp.o psb_cspgtdiag.o psb_cspgtblk.o psb_cspgetrow.o\ -# psb_ccssm.o psb_ccssv.o psb_ccsmm.o psb_ccsmv.o psb_ctransp.o psb_ctransc.o\ -# psb_cspclip.o psb_crwextd.o psb_cspscal.o\ -# psb_cnumbmm.o psb_csymbmm.o psb_cneigh.o -#FOBJS = psb_cest.o psb_dcoins.o psb_dcsmm.o psb_dcsmv.o \ -# psb_dcsnmi.o psb_dcsprt.o psb_dcsrws.o psb_dcssm.o psb_dcssv.o \ -# psb_dfixcoo.o psb_dipcoo2csr.o psb_dipcsr2coo.o psb_dneigh.o \ -# psb_dnumbmm.o psb_drwextd.o psb_dspgtdiag.o psb_dspgtblk.o \ -# psb_dspscal.o psb_dsymbmm.o psb_dtransp.o psb_dspclip.o psb_dspcnv.o\ -# psb_regen_mod.o psb_dipcoo2csc.o psb_dspgetrow.o psb_lsame.o psb_zspgetrow.o\ -# psb_zcsmm.o psb_zcsmv.o psb_zspgtdiag.o psb_zspgtblk.o\ -# psb_zcsnmi.o psb_zcsrws.o psb_zcssm.o psb_zcssv.o psb_zspcnv.o\ -# psb_zfixcoo.o psb_zipcoo2csr.o psb_zipcsr2coo.o psb_zipcoo2csc.o \ -# psb_zcoins.o psb_zcsprt.o psb_zneigh.o psb_ztransp.o psb_ztransc.o\ -# psb_zrwextd.o psb_zsymbmm.o psb_znumbmm.o psb_zspscal.o psb_zspclip.o\ -# psb_getifield.o psb_setifield.o psb_update_mod.o psb_getrow_mod.o\ -# psb_dgelp.o psb_zgelp.o\ -# psb_dspshift.o psb_dspsetbld.o psb_zspshift.o psb_zspsetbld.o\ -# psb_scsprt.o psb_sspcnv.o psb_scoins.o psb_scsmm.o psb_scsmv.o \ -# psb_scssm.o psb_scssv.o psb_sneigh.o psb_sspgtblk.o psb_sspgetrow.o \ -# psb_sfixcoo.o psb_sipcsr2coo.o psb_sipcoo2csr.o psb_sipcoo2csc.o \ -# psb_sgelp.o psb_sspgtdiag.o psb_scsnmi.o psb_stransp.o \ -# psb_sspclip.o psb_srwextd.o psb_sspscal.o\ -# psb_snumbmm.o psb_ssymbmm.o\ -# psb_ccsprt.o psb_cspcnv.o psb_ccoins.o psb_ccsnmi.o\ -# psb_cfixcoo.o psb_cipcsr2coo.o psb_cipcoo2csr.o psb_cipcoo2csc.o \ -# psb_cgelp.o psb_cspgtdiag.o psb_cspgtblk.o psb_cspgetrow.o\ -# psb_ccssm.o psb_ccssv.o psb_ccsmm.o psb_ccsmv.o psb_ctransp.o psb_ctransc.o\ -# psb_cspclip.o psb_crwextd.o psb_cspscal.o\ -# psb_cnumbmm.o psb_csymbmm.o psb_cneigh.o -# psb_dcsrp.o psb_zcsrp.o\ LIBDIR=.. MODDIR=../modules FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG). -lib: auxd f77d f03d dpd lib1 +lib: auxd f77d f03d lib1 $(AR) $(LIBDIR)/$(LIBNAME) $(FOBJS) $(RANLIB) $(LIBDIR)/$(LIBNAME) @@ -60,26 +18,10 @@ lib: auxd f77d f03d dpd lib1 lib1: $(FOBJS) -psb_scoins.o psb_dcoins.o psb_zcoins.o: psb_update_mod.o -psb_sspgetrow.o psb_dspgetrow.o psb_zspgetrow.o: psb_getrow_mod.o -psb_sspcnv.o psb_dspcnv.o pzb_zspcnv.o: psb_regen_mod.o -#psb_sfixcoo.o psb_dfixcoo.o psb_cfixcoo.o psb_zfixcoo.o: psb_ip_reord_mod.o auxd: (cd aux; make lib) -cood: - (cd coo; make lib) - -csrd: - (cd csr; make lib) - -jadd: - (cd jad; make lib) - -dpd: - (cd dp; make lib) - f77d: (cd f77; make lib) f03d: @@ -88,10 +30,6 @@ f03d: clean: /bin/rm -f $(FOBJS) *$(.mod) (cd aux; make clean) - (cd coo; make clean) - (cd csr; make clean) - (cd jad; make clean) - (cd dp; make clean) (cd f77; make clean) (cd f03; make clean) diff --git a/base/serial/coo/Makefile b/base/serial/coo/Makefile deleted file mode 100644 index 25488981e..000000000 --- a/base/serial/coo/Makefile +++ /dev/null @@ -1,42 +0,0 @@ -include ../../../Make.inc - -# -# The object files -# -FOBJS = ccoonrmi.o ccoomm.o ccoomv.o ccoosm.o ccoosv.o ccoorws.o\ - zcoomm.o zcoomv.o zcoonrmi.o zcoorws.o zcoosm.o zcoosv.o - -# dcoonrmi.o dcoomm.o dcoomv.o dcoosm.o dcoosv.o dcoorws.o\ -#scoonrmi.o scoomm.o scoomv.o scoosm.o scoosv.o scoorws.o\ - - -OBJS=$(FOBJS) - -# -# Where the library should go, and how it is called. -# Note that we are regenerating most of libsparker.a on the fly. -#LIBNAME=libsparker.a -SPARKERDIR=.. -LIBDIR=../.. -MODDIR=../../modules -FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG)$(SPARKERDIR) $(FMFLAG). -LIBFILE=$(LIBDIR)/$(LIBNAME) - -# -# No change should be needed below -# - - -default: lib - -lib: $(OBJS) - $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) - $(RANLIB) $(LIBDIR)/$(LIBNAME) - -clean: cleanobjs - -veryclean: cleanobjs - -cleanobjs: - /bin/rm -f $(OBJS) - diff --git a/base/serial/coo/ccoomm.f b/base/serial/coo/ccoomm.f deleted file mode 100644 index f66b62d98..000000000 --- a/base/serial/coo/ccoomm.f +++ /dev/null @@ -1,96 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -c -c What if a wrong DESCRA is passed? -c -c -* -* - SUBROUTINE CCOOMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * IA,JA,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK) - use psb_const_mod -C -C -C .. Scalar Arguments .. - complex(psb_spk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N, LWORK - CHARACTER TRANSA -C .. Array Arguments .. - complex(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*),INFOA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J - CHARACTER DIAG, TRANS - - -C .. External Subroutines .. - EXTERNAL ZCOOMV -C .. Executable Statements .. -C -C -C - IF (DESCRA(1:1).EQ.'G') TRANS = TRANSA - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' -c -c Does DSRMV manage this case too? = 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE CCOOMV (TRANS,DIAG,M,N,ALPHA,AS,IA,JA,INFOA,X, - + BETA,Y,WORK) - use psb_const_mod -C .. Parameters .. - complex(psb_spk_) ONE, ZERO - PARAMETER (ONE=sone,ZERO=szero) -C .. Scalar Arguments .. - complex(psb_spk_) ALPHA, BETA - INTEGER M, N - CHARACTER DIAG, TRANS -C .. Array Arguments .. - complex(psb_spk_) AS(*), WORK(*), X(*), Y(*) - INTEGER IA(*), JA(*),infoa(*) -C .. Local Scalars .. - complex(psb_spk_) ACC, TX - INTEGER I, J, K, NCOLA, NROWA,DUM, NNZ, IR, JC - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) -C - IF ( .NOT. TRA) THEN - NROWA = M - NCOLA = N - ELSE IF (TRA) THEN - NROWA = N - NCOLA = M - END IF !(....TRA) - - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, M - Y(I) = ZERO - ENDDO - ELSE - DO 20 I = 1, M - Y(I) = BETA*Y(I) - 20 CONTINUE - ENDIF - RETURN - END IF - - NNZ = INFOA(1) -C - IF (SYM) THEN - IF (UNI) THEN -C -C ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - IF (BETA.NE.ZERO) THEN - DO I = 1, M -C -C Product for diagonal elements -C - Y(I) = BETA*Y(I) + ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C Product for other elements - - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO -C - ELSE IF ( .NOT. UNI) THEN -C -C Check if matrix is lower or upper -C - IF (TRANS.EQ.'L') THEN -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - IF (IR.NE.JC) THEN - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDIF - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - - ELSE ! ....Trans<>L -C -C UPPER CASE -C ....OK!! (Actually it's just the same as above!) -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - IF (IR.NE.JC) THEN - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDIF - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - END IF ! ......TRANS=='L' - - END IF ! ......Not UNI -C - ELSE IF ( .NOT. TRA) THEN !......NOT SYM - - IF ( .NOT. UNI) THEN -C -C .......General Not Unit, No Traspose -C - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I)+ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - END IF !....End Testing on UNI -C - ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I)+ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF -C - END IF !....UNI -C - IF (ALPHA.EQ.ONE) THEN -C - I = 1 - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) + AS(I)*X(JC) - ENDDO -C - ELSE IF (ALPHA.EQ.-ONE) THEN -C - I = 1 - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) - AS(I)*X(JC) - ENDDO -C - ELSE !.....Else on TRA - I = 1 - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) + ALPHA*AS(I)*X(JC) - ENDDO - -c$$$C -c$$$C This work array is used for efficiency -c$$$C -c$$$ DO 420 I = 1, N -c$$$ WORK(I) = ALPHA*X(I) -c$$$ 420 CONTINUE -c$$$C -c$$$ DO 460 I = 1, n -c$$$ DO 440 J = IA(I), IA(I+1) - 1 -c$$$ K = JA(J) -c$$$ Y(K) = Y(K) + AS(J)*WORK(I) -c$$$ 440 CONTINUE -c$$$ 460 CONTINUE -c$$$C - END IF !.....End testing on ALPHA - - END IF !.....End testing on SYM -C - RETURN -C -C END OF DSRMV -C - END - diff --git a/base/serial/coo/ccoonrmi.f b/base/serial/coo/ccoonrmi.f deleted file mode 100644 index 53291cc5d..000000000 --- a/base/serial/coo/ccoonrmi.f +++ /dev/null @@ -1,70 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C ... Compute Infinity norm for sparse matrix in CSR Format ... - FUNCTION CCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_spk_) ccoonrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - complex(psb_spk_) A(*) -C .. Local scalars .. - INTEGER I, J, K, NNZ - real(psb_spk_) NRMI, SUM - - NRMI = 0.0 - NNZ = INFOA(1) - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA1(J).EQ.IA1(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - SUM = 0.0 - DO K = I, J-1 - SUM = SUM + ABS(DBLE(A(K))) + ABS(AIMAG(A(K))) - ENDDO - IF (SUM.GT.NRMI) THEN - NRMI = SUM - ENDIF - I = J - ENDDO - - CCOONRMI = NRMI - END diff --git a/base/serial/coo/ccoorws.f b/base/serial/coo/ccoorws.f deleted file mode 100644 index a283d757b..000000000 --- a/base/serial/coo/ccoorws.f +++ /dev/null @@ -1,85 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C - SUBROUTINE CCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - complex(psb_spk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER I, J, NNZ, K - real(psb_spk_) SUM - logical psb_lsame - external psb_lsame - - NNZ = INFOA(1) - IF (psb_lsame(TRANS,'N')) THEN - DO I=1, M - ROWSUM(I) = 0.0D0 - ENDDO - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA1(J).EQ.IA1(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - SUM = 0.0 - DO K = I, J-1 - SUM = SUM + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - ROWSUM(IA1(I)) = ROWSUM(IA1(I)) + SUM - I = J - ENDDO - - ELSE IF (psb_lsame(TRANS,'T').OR.psb_lsame(TRANS,'C')) THEN - DO J = 1, N - ROWSUM(J) = 0.0D0 - ENDDO - DO I = 1, NNZ - ROWSUM(IA2(I)) = ROWSUM(IA2(I)) + - + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - ELSE - ierror = -1 - ENDIF - RETURN - END - - - diff --git a/base/serial/coo/ccoosm.f b/base/serial/coo/ccoosm.f deleted file mode 100644 index d82527a18..000000000 --- a/base/serial/coo/ccoosm.f +++ /dev/null @@ -1,115 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE CCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA, - * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_error_mod - IMPLICIT NONE - complex(psb_spk_) ALPHA, BETA - INTEGER LDB, LDC, LWORK, M, N, IERROR - CHARACTER UNITD, TRANST - complex(psb_spk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IA(*), JA(*), INFOA(*), INT_VAL(5) - CHARACTER DESCRA*11 - INTEGER I, K, ERR_ACT - CHARACTER DIAG, UPLO - INTRINSIC DBLE, IDINT - CHARACTER*20 NAME - integer :: debug_level, debug_unit - - NAME = 'CCOOSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),':' ,m,ierror - - UPLO = '?' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' - IF (UPLO.EQ.'?') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' - IF(UNITD.EQ.'B') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF (UNITD.EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE - END IF - - DO 60 I = 1, N - CALL CCOOSV(UPLO,TRANST,DIAG,M,A,IA,JA,INFOA, - + B(1,I),C(1,I),IERROR) - 60 CONTINUE - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE - END IF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/coo/ccoosv.f b/base/serial/coo/ccoosv.f deleted file mode 100644 index 7bd6bf260..000000000 --- a/base/serial/coo/ccoosv.f +++ /dev/null @@ -1,225 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Assumption: the triangular matrix has the diagonal element in the -C "right" place, i.e. the last in its row for Lower and the first -C for Upper. -C - SUBROUTINE CCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR) - use psb_const_mod - use psb_error_mod - complex(psb_spk_) ZERO - PARAMETER (ZERO=(0.0,0.0)) - INTEGER N,IERROR - CHARACTER DIAG, TRANS, UPLO - complex(psb_spk_) AS(*), B(*), X(*) - INTEGER IA(*), JA(*),INFOA(*) - complex(psb_spk_) ACC - INTEGER I, J, K, NNZ, II, JJ - LOGICAL LOW, TRA, UNI - integer :: debug_level, debug_unit - character(len=20) :: name='ccoosv' - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - LOW = (UPLO.EQ.'L') - NNZ = INFOA(1) - IERROR = 0 - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),':',n,nnz,diag,trans,uplo - IF ( .NOT. TRA) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT TRA' - IF (LOW) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': LOW' - IF ( .NOT. UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT UNI' - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-2 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - X(IR) = (B(IR)-ACC)/AS(J-1) - I = J - ENDDO - - ELSE IF (UNI) THEN -C -C Bug warning: if UNI, some rows might be empty -C - I = 1 - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': UNILOW ', - + i,n,nnz,uni,tra,low - DO II = 1, N - DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II)) - I = I + 1 - ENDDO - ACC = ZERO - IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN - J = I + 1 - DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) - J = J+1 - ENDDO - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - ELSE - J = I - ENDIF - X(II) = (B(II)-ACC) - I = J - ENDDO - - END IF - - ELSE IF ( .NOT. LOW) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT LOW' - IF ( .NOT. UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT UNI' - I = NNZ - J = NNZ - DO WHILE (I.GT.0) - DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) - J = J-1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J+2,-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - X(IR) = (B(IR)-ACC)/AS(J+1) - I = J - ENDDO - - ELSE IF (UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': UNI' - I = NNZ - DO II = N,1,-1 - DO WHILE ((I.GT.0).AND.(IA(I).GT.II)) - I = I -1 - ENDDO - ACC = ZERO - IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN - J = I - 1 - DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) - J = J-1 - ENDDO - DO K = I, J+1, -1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - ELSE - J = I - ENDIF - X(II) = (B(II)-ACC) - I = J - ENDDO - - END IF - - END IF - - ELSE IF (TRA) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': TRA' - IERROR = 3010 - return -CCCCCCCCCCCCCCCC -C -C TBF -C -CCCCCCCCCCCCCCCC - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF - END IF - RETURN - END - - - diff --git a/base/serial/coo/dcoomm.f b/base/serial/coo/dcoomm.f deleted file mode 100644 index 1fe600a94..000000000 --- a/base/serial/coo/dcoomm.f +++ /dev/null @@ -1,98 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -c -c What if a wrong DESCRA is passed? -c -c -* -* - SUBROUTINE DCOOMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * IA,JA,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod -C -C -C .. Scalar Arguments .. - real(psb_dpk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N, LWORK, IERROR - CHARACTER TRANSA -C .. Array Arguments .. - real(psb_dpk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*),INFOA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J - CHARACTER DIAG, TRANS - - -C .. External Subroutines .. - EXTERNAL DCOOMV -C .. Executable Statements .. -C -C -C - IERROR=0 - TRANS = TRANSA - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' -c -c Does DSRMV manage this case too? = 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE DCOOMV (TRANS,DIAG,M,N,ALPHA,AS,IA,JA,INFOA,X, - + BETA,Y,WORK,IERROR) - use psb_const_mod -C .. Parameters .. - real(psb_dpk_) ONE, ZERO - PARAMETER (ONE=1.0D0,ZERO=0.0D0) -C .. Scalar Arguments .. - real(psb_dpk_) ALPHA, BETA - INTEGER M, N, IERROR - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_dpk_) AS(*), WORK(*), X(*), Y(*) - INTEGER IA(*), JA(*),infoa(*) -C .. Local Scalars .. - real(psb_dpk_) ACC, TX - INTEGER I, J, K, NNZ, IR, JC - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR=0 - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) -C - - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, M - Y(I) = ZERO - ENDDO - ELSE - DO 20 I = 1, M - Y(I) = BETA*Y(I) - 20 CONTINUE - ENDIF - RETURN - END IF - - NNZ = INFOA(1) -C - IF (SYM) THEN - IF (UNI) THEN -C -C ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - IF (BETA.NE.ZERO) THEN - DO I = 1, M -C -C Product for diagonal elements -C - Y(I) = BETA*Y(I) + ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C Product for other elements - - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO -C - ELSE IF ( .NOT. UNI) THEN -C -C Check if matrix is lower or upper -C - IF (TRANS.EQ.'L') THEN -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - IF (IR.NE.JC) THEN - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDIF - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - - ELSE ! ....Trans<>L -C -C UPPER CASE -C ....OK!! (Actually it's just the same as above!) -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - IF (IR.NE.JC) THEN - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDIF - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - END IF ! ......TRANS=='L' - - END IF ! ......Not UNI -C - ELSE IF ( .NOT. TRA) THEN !......NOT SYM - - IF ( .NOT. UNI) THEN -C -C .......General Not Unit, No Traspose -C - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - IF (nnz > 0) then - IR = IA(1) - ACC = zero - DO - if (i>nnz) then - Y(IR) = Y(IR) + ALPHA * ACC - exit - endif - IF (IA(I) /= IR) THEN - Y(IR) = Y(IR) + ALPHA * ACC - IR = IA(I) - ACC = ZERO - ENDIF - ACC = ACC + AS(I) * X(JA(I)) - I = I + 1 - ENDDO - endif -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I)+ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - END IF !....End Testing on UNI -C - ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I)+ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF -C - END IF !....UNI -C - IF (ALPHA.EQ.ONE) THEN -C - I = 1 - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) + AS(I)*X(JC) - ENDDO -C - ELSE IF (ALPHA.EQ.-ONE) THEN -C - - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) - AS(I)*X(JC) - ENDDO -C - ELSE !.....Else on TRA - - DO I=1,M - WORK(I) = ALPHA*X(I) - ENDDO - - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) + AS(I)*WORK(JC) - ENDDO - - END IF !.....End testing on ALPHA - - END IF !.....End testing on SYM -C - RETURN -C -C END OF DSRMV -C - END - diff --git a/base/serial/coo/dcoonrmi.f b/base/serial/coo/dcoonrmi.f deleted file mode 100644 index cee4bad13..000000000 --- a/base/serial/coo/dcoonrmi.f +++ /dev/null @@ -1,72 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute Infinity norm for sparse matrix in CSR Format ... - FUNCTION DCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) dcoonrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_dpk_) A(*) -C .. Local scalars .. - INTEGER I, J, K, NNZ - real(psb_dpk_) NRMI, SUM - - IERROR=0 - NRMI = 0.0 - NNZ = INFOA(1) - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA1(J).EQ.IA1(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - SUM = 0.0 - DO K = I, J-1 - SUM = SUM + ABS(A(K)) - ENDDO - IF (SUM.GT.NRMI) THEN - NRMI = SUM - ENDIF - I = J - ENDDO - - DCOONRMI = NRMI - END diff --git a/base/serial/coo/dcoorws.f b/base/serial/coo/dcoorws.f deleted file mode 100644 index aa7dc88f4..000000000 --- a/base/serial/coo/dcoorws.f +++ /dev/null @@ -1,85 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_dpk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER I, J, NNZ, K - real(psb_dpk_) SUM - logical psb_lsame - external psb_lsame - - NNZ = INFOA(1) - IF (psb_lsame(TRANS,'N')) THEN - DO I=1, M - ROWSUM(I) = 0.0D0 - ENDDO - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA1(J).EQ.IA1(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - SUM = 0.0 - DO K = I, J-1 - SUM = SUM + ABS(A(K)) - ENDDO - ROWSUM(IA1(I)) = ROWSUM(IA1(I)) + SUM - I = J - ENDDO - - ELSE IF (psb_lsame(TRANS,'T').OR.psb_lsame(TRANS,'C')) THEN - DO J = 1, N - ROWSUM(J) = 0.0D0 - ENDDO - DO I = 1, NNZ - ROWSUM(IA2(I)) = ROWSUM(IA2(I)) + ABS(A(I)) - ENDDO - ELSE - ierror = -1 - ENDIF - RETURN - END - - - diff --git a/base/serial/coo/dcoosm.f b/base/serial/coo/dcoosm.f deleted file mode 100644 index 96dbc6a18..000000000 --- a/base/serial/coo/dcoosm.f +++ /dev/null @@ -1,115 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA, - * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_error_mod - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) ALPHA, BETA - INTEGER LDB, LDC, LWORK, M, N, IERROR - CHARACTER UNITD, TRANST - real(psb_dpk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IA(*), JA(*), INFOA(*), INT_VAL(5) - CHARACTER DESCRA*11 - INTEGER I, K, ERR_ACT - CHARACTER DIAG, UPLO - INTRINSIC DBLE, IDINT - CHARACTER*20 NAME - integer :: debug_level, debug_unit - - NAME = 'DCOOSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),':' ,m,ierror - - UPLO = '?' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' - IF (UPLO.EQ.'?') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' - IF(UNITD.EQ.'B') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF (UNITD.EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE - END IF - - DO 60 I = 1, N - CALL DCOOSV(UPLO,TRANST,DIAG,M,A,IA,JA,INFOA, - + B(1,I),C(1,I),IERROR) - 60 CONTINUE - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE - END IF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/coo/dcoosv.f b/base/serial/coo/dcoosv.f deleted file mode 100644 index 46755648f..000000000 --- a/base/serial/coo/dcoosv.f +++ /dev/null @@ -1,226 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Assumption: the triangular matrix has the diagonal element in the -C "right" place, i.e. the last in its row for Lower and the first -C for Upper. -C - SUBROUTINE DCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR) - use psb_const_mod - use psb_error_mod - real(psb_dpk_) ZERO - PARAMETER (ZERO=0.0D0) - INTEGER N,IERROR - CHARACTER DIAG, TRANS, UPLO - real(psb_dpk_) AS(*), B(*), X(*) - INTEGER IA(*), JA(*),INFOA(*) - real(psb_dpk_) ACC - INTEGER I, J, K, NNZ, II - LOGICAL LOW, TRA, UNI - integer :: debug_level, debug_unit - character(len=20) :: name='dcoosv' - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - LOW = (UPLO.EQ.'L') - NNZ = INFOA(1) - IERROR = 0 - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),':',n,nnz,diag,trans,uplo - IF ( .NOT. TRA) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT TRA' - IF (LOW) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': LOW' - IF ( .NOT. UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT UNI' - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-2 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - X(IR) = (B(IR)-ACC)/AS(J-1) - I = J - ENDDO - - ELSE IF (UNI) THEN -C -C Bug warning: if UNI, some rows might be empty -C - I = 1 - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': UNILOW ', - + i,n,nnz,uni,tra,low - DO II = 1, N - DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II)) - I = I + 1 - ENDDO - ACC = ZERO - IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN - J = I + 1 - DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) - J = J+1 - ENDDO - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - ELSE - J = I - ENDIF - X(II) = (B(II)-ACC) - I = J - ENDDO - - END IF - - ELSE IF ( .NOT. LOW) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT LOW' - IF ( .NOT. UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT UNI' - I = NNZ - J = NNZ - DO WHILE (I.GT.0) - DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) - J = J-1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J+2,-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - X(IR) = (B(IR)-ACC)/AS(J+1) - I = J - ENDDO - - ELSE IF (UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': UNI' - I = NNZ - DO II = N,1,-1 - DO WHILE ((I.GT.0).AND.(IA(I).GT.II)) - I = I -1 - ENDDO - ACC = ZERO - IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN - J = I - 1 - DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) - J = J-1 - ENDDO - DO K = I, J+1, -1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - ELSE - J = I - ENDIF - X(II) = (B(II)-ACC) - I = J - ENDDO - - END IF - - END IF - - ELSE IF (TRA) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': TRA' - IERROR = 3010 - return -CCCCCCCCCCCCCCCC -C -C TBF -C -CCCCCCCCCCCCCCCC - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF - END IF - RETURN - END - - - diff --git a/base/serial/coo/scoomm.f b/base/serial/coo/scoomm.f deleted file mode 100644 index 0251011d4..000000000 --- a/base/serial/coo/scoomm.f +++ /dev/null @@ -1,98 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -c -c What if a wrong DESCRA is passed? -c -c -* -* - SUBROUTINE SCOOMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * IA,JA,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod -C -C -C .. Scalar Arguments .. - real(psb_spk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N, LWORK, IERROR - CHARACTER TRANSA -C .. Array Arguments .. - real(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*),INFOA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J - CHARACTER DIAG, TRANS - - -C .. External Subroutines .. - EXTERNAL SCOOMV -C .. Executable Statements .. -C -C -C - IERROR=0 - IF (DESCRA(1:1).EQ.'G') TRANS = TRANSA - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' -c -c Does DSRMV manage this case too? = 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE SCOOMV(TRANS,DIAG,M,N,ALPHA,AS,IA,JA,INFOA,X, - + BETA,Y,WORK,IERROR) - use psb_const_mod -C .. Scalar Arguments .. - real(psb_spk_) ALPHA, BETA - INTEGER M, N, IERROR - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_spk_) AS(*), WORK(*), X(*), Y(*) - INTEGER IA(*), JA(*),infoa(*) -C .. Local Scalars .. - real(psb_spk_) ACC, TX - INTEGER I, J, K, NNZ, IR, JC - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR=0 - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) -C - - IF (ALPHA.EQ.SZERO) THEN - IF (BETA.EQ.SZERO) THEN - DO I = 1, M - Y(I) = SZERO - ENDDO - ELSE - DO 20 I = 1, M - Y(I) = BETA*Y(I) - 20 CONTINUE - ENDIF - RETURN - END IF - - NNZ = INFOA(1) -C - IF (SYM) THEN - IF (UNI) THEN -C -C ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - IF (BETA.NE.SZERO) THEN - DO I = 1, M -C -C Product for diagonal elements -C - Y(I) = BETA*Y(I) + ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C Product for other elements - - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - ACC = SZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO -C - ELSE IF ( .NOT. UNI) THEN -C -C Check if matrix is lower or upper -C - IF (TRANS.EQ.'L') THEN -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - IF (BETA.NE.SZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = SZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = SZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - IF (IR.NE.JC) THEN - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDIF - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - - ELSE ! ....Trans<>L -C -C UPPER CASE -C ....OK!! (Actually it's just the same as above!) -C - - IF (BETA.NE.SZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = SZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = SZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - IF (IR.NE.JC) THEN - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDIF - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - END IF ! ......TRANS=='L' - - END IF ! ......Not UNI -C - ELSE IF ( .NOT. TRA) THEN !......NOT SYM - - IF ( .NOT. UNI) THEN -C -C .......General Not Unit, No Traspose -C - IF (BETA.NE.SZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = SZERO - ENDDO - ENDIF - - I = 1 - J = I - IF (nnz > 0) then - IR = IA(1) - ACC = szero - DO - if (i>nnz) then - Y(IR) = Y(IR) + ALPHA * ACC - exit - endif - IF (IA(I) /= IR) THEN - Y(IR) = Y(IR) + ALPHA * ACC - IR = IA(I) - ACC = SZERO - ENDIF - ACC = ACC + AS(I) * X(JA(I)) - I = I + 1 - ENDDO - endif -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.SZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I)+ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = SZERO - IR = IA(I) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - END IF !....End Testing on UNI -C - ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.SZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = SZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.SZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I)+ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF -C - END IF !....UNI -C - IF (ALPHA.EQ.SONE) THEN -C - I = 1 - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) + AS(I)*X(JC) - ENDDO -C - ELSE IF (ALPHA.EQ.-SONE) THEN -C - - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) - AS(I)*X(JC) - ENDDO -C - ELSE !.....Else on TRA - - DO I=1,M - WORK(I) = ALPHA*X(I) - ENDDO - - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) + AS(I)*WORK(JC) - ENDDO - - END IF !.....End testing on ALPHA - - END IF !.....End testing on SYM -C - RETURN -C -C END OF DSRMV -C - END - diff --git a/base/serial/coo/scoonrmi.f b/base/serial/coo/scoonrmi.f deleted file mode 100644 index 8a22f32a8..000000000 --- a/base/serial/coo/scoonrmi.f +++ /dev/null @@ -1,73 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute Infinity norm for sparse matrix in CSR Format ... - FUNCTION SCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_spk_) scoonrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_spk_) A(*) -C .. Local scalars .. - INTEGER I, J, K, NNZ - real(psb_spk_) NRMI, SUM - - IERROR=0 - NRMI = 0.0 - NNZ = INFOA(1) - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA1(J).EQ.IA1(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - SUM = 0.0 - DO K = I, J-1 - SUM = SUM + ABS(A(K)) - ENDDO - IF (SUM.GT.NRMI) THEN - NRMI = SUM - ENDIF - I = J - ENDDO - - SCOONRMI = NRMI - RETURN - END diff --git a/base/serial/coo/scoorws.f b/base/serial/coo/scoorws.f deleted file mode 100644 index 798939c3b..000000000 --- a/base/serial/coo/scoorws.f +++ /dev/null @@ -1,85 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_spk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER I, J, NNZ, K - real(psb_spk_) SUM - logical psb_lsame - external psb_lsame - - NNZ = INFOA(1) - IF (psb_lsame(TRANS,'N')) THEN - DO I=1, M - ROWSUM(I) = 0.0D0 - ENDDO - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA1(J).EQ.IA1(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - SUM = 0.0 - DO K = I, J-1 - SUM = SUM + ABS(A(K)) - ENDDO - ROWSUM(IA1(I)) = ROWSUM(IA1(I)) + SUM - I = J - ENDDO - - ELSE IF (psb_lsame(TRANS,'T').OR.psb_lsame(TRANS,'C')) THEN - DO J = 1, N - ROWSUM(J) = 0.0D0 - ENDDO - DO I = 1, NNZ - ROWSUM(IA2(I)) = ROWSUM(IA2(I)) + ABS(A(I)) - ENDDO - ELSE - ierror = -1 - ENDIF - RETURN - END - - - diff --git a/base/serial/coo/scoosm.f b/base/serial/coo/scoosm.f deleted file mode 100644 index 9d1a40aec..000000000 --- a/base/serial/coo/scoosm.f +++ /dev/null @@ -1,115 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA, - * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_error_mod - use psb_const_mod - IMPLICIT NONE - real(psb_spk_) ALPHA, BETA - INTEGER LDB, LDC, LWORK, M, N, IERROR - CHARACTER UNITD, TRANST - real(psb_spk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IA(*), JA(*), INFOA(*), INT_VAL(5) - CHARACTER DESCRA*11 - INTEGER I, K, ERR_ACT - CHARACTER DIAG, UPLO - INTRINSIC DBLE, IDINT - CHARACTER*20 NAME - integer :: debug_level, debug_unit - - NAME = 'SCOOSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),':' ,m,ierror - - UPLO = '?' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' - IF (UPLO.EQ.'?') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' - IF(UNITD.EQ.'B') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF (UNITD.EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE - END IF - - DO 60 I = 1, N - CALL SCOOSV(UPLO,TRANST,DIAG,M,A,IA,JA,INFOA, - + B(1,I),C(1,I),IERROR) - 60 CONTINUE - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE - END IF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/coo/scoosv.f b/base/serial/coo/scoosv.f deleted file mode 100644 index 764c39df6..000000000 --- a/base/serial/coo/scoosv.f +++ /dev/null @@ -1,226 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Assumption: the triangular matrix has the diagonal element in the -C "right" place, i.e. the last in its row for Lower and the first -C for Upper. -C - SUBROUTINE SCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR) - use psb_const_mod - use psb_error_mod - real(psb_spk_) ZERO - PARAMETER (ZERO=0.0e0) - INTEGER N,IERROR - CHARACTER DIAG, TRANS, UPLO - real(psb_spk_) AS(*), B(*), X(*) - INTEGER IA(*), JA(*),INFOA(*) - real(psb_spk_) ACC - INTEGER I, J, K, NNZ, II - LOGICAL LOW, TRA, UNI - integer :: debug_level, debug_unit - character(len=20) :: name='dcoosv' - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - LOW = (UPLO.EQ.'L') - NNZ = INFOA(1) - IERROR = 0 - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),':',n,nnz,diag,trans,uplo - IF ( .NOT. TRA) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT TRA' - IF (LOW) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': LOW' - IF ( .NOT. UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT UNI' - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-2 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - X(IR) = (B(IR)-ACC)/AS(J-1) - I = J - ENDDO - - ELSE IF (UNI) THEN -C -C Bug warning: if UNI, some rows might be empty -C - I = 1 - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': UNILOW ', - + i,n,nnz,uni,tra,low - DO II = 1, N - DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II)) - I = I + 1 - ENDDO - ACC = ZERO - IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN - J = I + 1 - DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) - J = J+1 - ENDDO - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - ELSE - J = I - ENDIF - X(II) = (B(II)-ACC) - I = J - ENDDO - - END IF - - ELSE IF ( .NOT. LOW) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT LOW' - IF ( .NOT. UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT UNI' - I = NNZ - J = NNZ - DO WHILE (I.GT.0) - DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) - J = J-1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J+2,-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - X(IR) = (B(IR)-ACC)/AS(J+1) - I = J - ENDDO - - ELSE IF (UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': UNI' - I = NNZ - DO II = N,1,-1 - DO WHILE ((I.GT.0).AND.(IA(I).GT.II)) - I = I -1 - ENDDO - ACC = ZERO - IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN - J = I - 1 - DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) - J = J-1 - ENDDO - DO K = I, J+1, -1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - ELSE - J = I - ENDIF - X(II) = (B(II)-ACC) - I = J - ENDDO - - END IF - - END IF - - ELSE IF (TRA) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': TRA' - IERROR = 3010 - return -CCCCCCCCCCCCCCCC -C -C TBF -C -CCCCCCCCCCCCCCCC - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF - END IF - RETURN - END - - - diff --git a/base/serial/coo/zcoomm.f b/base/serial/coo/zcoomm.f deleted file mode 100644 index ab26fef42..000000000 --- a/base/serial/coo/zcoomm.f +++ /dev/null @@ -1,96 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -c -c What if a wrong DESCRA is passed? -c -c -* -* - SUBROUTINE ZCOOMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * IA,JA,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK) - use psb_const_mod -C -C -C .. Scalar Arguments .. - complex(psb_dpk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N, LWORK - CHARACTER TRANSA -C .. Array Arguments .. - complex(psb_dpk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*),INFOA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J - CHARACTER DIAG, TRANS - - -C .. External Subroutines .. - EXTERNAL ZCOOMV -C .. Executable Statements .. -C -C -C - IF (DESCRA(1:1).EQ.'G') TRANS = TRANSA - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' -c -c Does DSRMV manage this case too? = 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE ZCOOMV (TRANS,DIAG,M,N,ALPHA,AS,IA,JA,INFOA,X, - + BETA,Y,WORK) - use psb_const_mod -C .. Parameters .. - complex(psb_dpk_) ONE, ZERO - PARAMETER (ONE=(1.0D0,0.0D0),ZERO=(0.0D0,0.0D0)) -C .. Scalar Arguments .. - complex(psb_dpk_) ALPHA, BETA - INTEGER M, N - CHARACTER DIAG, TRANS -C .. Array Arguments .. - complex(psb_dpk_) AS(*), WORK(*), X(*), Y(*) - INTEGER IA(*), JA(*),infoa(*) -C .. Local Scalars .. - complex(psb_dpk_) ACC, TX - INTEGER I, J, K, NCOLA, NROWA,DUM, NNZ, IR, JC - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((TRANS.EQ.'L').OR.(TRANS.EQ.'U')) -C - IF ( .NOT. TRA) THEN - NROWA = M - NCOLA = N - ELSE IF (TRA) THEN - NROWA = N - NCOLA = M - END IF !(....TRA) - - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, M - Y(I) = ZERO - ENDDO - ELSE - DO 20 I = 1, M - Y(I) = BETA*Y(I) - 20 CONTINUE - ENDIF - RETURN - END IF - - NNZ = INFOA(1) -C - IF (SYM) THEN - IF (UNI) THEN -C -C ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - IF (BETA.NE.ZERO) THEN - DO I = 1, M -C -C Product for diagonal elements -C - Y(I) = BETA*Y(I) + ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C Product for other elements - - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO -C - ELSE IF ( .NOT. UNI) THEN -C -C Check if matrix is lower or upper -C - IF (TRANS.EQ.'L') THEN -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - IF (IR.NE.JC) THEN - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDIF - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - - ELSE ! ....Trans<>L -C -C UPPER CASE -C ....OK!! (Actually it's just the same as above!) -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - TX = X(IR) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - IF (IR.NE.JC) THEN - Y(JC) = Y(JC) + ALPHA * AS(K)*TX - ENDIF - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - END IF ! ......TRANS=='L' - - END IF ! ......Not UNI -C - ELSE IF ( .NOT. TRA) THEN !......NOT SYM - - IF ( .NOT. UNI) THEN -C -C .......General Not Unit, No Traspose -C - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I)+ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA(J).EQ.IA(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - Y(IR) = Y(IR) + ALPHA * ACC - I = J - ENDDO - - END IF !....End Testing on UNI -C - ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO I = 1, M - Y(I) = BETA*Y(I)+ALPHA*X(I) - ENDDO - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF -C - END IF !....UNI -C - IF (ALPHA.EQ.ONE) THEN -C - I = 1 - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) + AS(I)*X(JC) - ENDDO -C - ELSE IF (ALPHA.EQ.-ONE) THEN -C - I = 1 - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) - AS(I)*X(JC) - ENDDO -C - ELSE !.....Else on TRA - I = 1 - DO I=1,NNZ - IR = JA(I) - JC = IA(I) - Y(IR) = Y(IR) + ALPHA*AS(I)*X(JC) - ENDDO - -c$$$C -c$$$C This work array is used for efficiency -c$$$C -c$$$ DO 420 I = 1, N -c$$$ WORK(I) = ALPHA*X(I) -c$$$ 420 CONTINUE -c$$$C -c$$$ DO 460 I = 1, n -c$$$ DO 440 J = IA(I), IA(I+1) - 1 -c$$$ K = JA(J) -c$$$ Y(K) = Y(K) + AS(J)*WORK(I) -c$$$ 440 CONTINUE -c$$$ 460 CONTINUE -c$$$C - END IF !.....End testing on ALPHA - - END IF !.....End testing on SYM -C - RETURN -C -C END OF DSRMV -C - END - diff --git a/base/serial/coo/zcoonrmi.f b/base/serial/coo/zcoonrmi.f deleted file mode 100644 index 9450a492d..000000000 --- a/base/serial/coo/zcoonrmi.f +++ /dev/null @@ -1,70 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C ... Compute Infinity norm for sparse matrix in CSR Format ... - FUNCTION ZCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) zcoonrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - complex(psb_dpk_) A(*) -C .. Local scalars .. - INTEGER I, J, K, NNZ - real(psb_dpk_) NRMI, SUM - - NRMI = 0.0 - NNZ = INFOA(1) - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA1(J).EQ.IA1(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - SUM = 0.0 - DO K = I, J-1 - SUM = SUM + ABS(DBLE(A(K))) + ABS(AIMAG(A(K))) - ENDDO - IF (SUM.GT.NRMI) THEN - NRMI = SUM - ENDIF - I = J - ENDDO - - ZCOONRMI = NRMI - END diff --git a/base/serial/coo/zcoorws.f b/base/serial/coo/zcoorws.f deleted file mode 100644 index 8919a9dc9..000000000 --- a/base/serial/coo/zcoorws.f +++ /dev/null @@ -1,85 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C - SUBROUTINE ZCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - complex(psb_dpk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER I, J, NNZ, K - real(psb_dpk_) SUM - logical psb_lsame - external psb_lsame - - NNZ = INFOA(1) - IF (psb_lsame(TRANS,'N')) THEN - DO I=1, M - ROWSUM(I) = 0.0D0 - ENDDO - I = 1 - J = I - DO WHILE (I.LE.NNZ) - - DO WHILE ((IA1(J).EQ.IA1(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - - SUM = 0.0 - DO K = I, J-1 - SUM = SUM + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - ROWSUM(IA1(I)) = ROWSUM(IA1(I)) + SUM - I = J - ENDDO - - ELSE IF (psb_lsame(TRANS,'T').OR.psb_lsame(TRANS,'C')) THEN - DO J = 1, N - ROWSUM(J) = 0.0D0 - ENDDO - DO I = 1, NNZ - ROWSUM(IA2(I)) = ROWSUM(IA2(I)) + - + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - ELSE - ierror = -1 - ENDIF - RETURN - END - - - diff --git a/base/serial/coo/zcoosm.f b/base/serial/coo/zcoosm.f deleted file mode 100644 index b35394bb1..000000000 --- a/base/serial/coo/zcoosm.f +++ /dev/null @@ -1,115 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE ZCOOSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,IA,JA,INFOA, - * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_error_mod - IMPLICIT NONE - complex(psb_dpk_) ALPHA, BETA - INTEGER LDB, LDC, LWORK, M, N, IERROR - CHARACTER UNITD, TRANST - complex(psb_dpk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IA(*), JA(*), INFOA(*), INT_VAL(5) - CHARACTER DESCRA*11 - INTEGER I, K, ERR_ACT - CHARACTER DIAG, UPLO - INTRINSIC DBLE, IDINT - CHARACTER*20 NAME - integer :: debug_level, debug_unit - - NAME = 'ZCOOSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),':' ,m,ierror - - UPLO = '?' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') UPLO = 'U' - IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') UPLO = 'L' - IF (UPLO.EQ.'?') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' - IF(UNITD.EQ.'B') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF (UNITD.EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE - END IF - - DO 60 I = 1, N - CALL ZCOOSV(UPLO,TRANST,DIAG,M,A,IA,JA,INFOA, - + B(1,I),C(1,I),IERROR) - 60 CONTINUE - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE - END IF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/coo/zcoosv.f b/base/serial/coo/zcoosv.f deleted file mode 100644 index 99764c930..000000000 --- a/base/serial/coo/zcoosv.f +++ /dev/null @@ -1,225 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Assumption: the triangular matrix has the diagonal element in the -C "right" place, i.e. the last in its row for Lower and the first -C for Upper. -C - SUBROUTINE ZCOOSV (UPLO,TRANS,DIAG,N,AS,IA,JA,INFOA,B,X,IERROR) - use psb_const_mod - use psb_error_mod - complex(psb_dpk_) ZERO - PARAMETER (ZERO=(0.0D0,0.0D0)) - INTEGER N,IERROR - CHARACTER DIAG, TRANS, UPLO - complex(psb_dpk_) AS(*), B(*), X(*) - INTEGER IA(*), JA(*),INFOA(*) - complex(psb_dpk_) ACC - INTEGER I, J, K, NNZ, II, JJ - LOGICAL LOW, TRA, UNI - integer :: debug_level, debug_unit - character(len=20) :: name='zcoosv' - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - UNI = (DIAG.EQ.'U') - TRA = (TRANS.EQ.'T') - LOW = (UPLO.EQ.'L') - NNZ = INFOA(1) - IERROR = 0 - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),':',n,nnz,diag,trans,uplo - IF ( .NOT. TRA) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT TRA' - IF (LOW) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': LOW' - IF ( .NOT. UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT UNI' - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) - J = J+1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J-2 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - X(IR) = (B(IR)-ACC)/AS(J-1) - I = J - ENDDO - - ELSE IF (UNI) THEN -C -C Bug warning: if UNI, some rows might be empty -C - I = 1 - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': UNILOW ', - + i,n,nnz,uni,tra,low - DO II = 1, N - DO WHILE ((I.LE.NNZ).AND.(IA(I).LT.II)) - I = I + 1 - ENDDO - ACC = ZERO - IF ((I.LE.NNZ).AND.(IA(I).EQ.II)) THEN - J = I + 1 - DO WHILE ((J.LE.NNZ).AND.(IA(J).EQ.IA(I))) - J = J+1 - ENDDO - DO K = I, J-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - ELSE - J = I - ENDIF - X(II) = (B(II)-ACC) - I = J - ENDDO - - END IF - - ELSE IF ( .NOT. LOW) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT LOW' - IF ( .NOT. UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NOT UNI' - I = NNZ - J = NNZ - DO WHILE (I.GT.0) - DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) - J = J-1 - ENDDO - ACC = ZERO - IR = IA(I) - DO K = I, J+2,-1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - X(IR) = (B(IR)-ACC)/AS(J+1) - I = J - ENDDO - - ELSE IF (UNI) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': UNI' - I = NNZ - DO II = N,1,-1 - DO WHILE ((I.GT.0).AND.(IA(I).GT.II)) - I = I -1 - ENDDO - ACC = ZERO - IF ((I.GT.0).AND.(IA(I).EQ.II)) THEN - J = I - 1 - DO WHILE ((J.GT.0).AND.(IA(J).EQ.IA(I))) - J = J-1 - ENDDO - DO K = I, J+1, -1 - JC = JA(K) - ACC = ACC + AS(K)*X(JC) - ENDDO - ELSE - J = I - ENDIF - X(II) = (B(II)-ACC) - I = J - ENDDO - - END IF - - END IF - - ELSE IF (TRA) THEN - if (debug_level>=psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': TRA' - IERROR = 3010 - return -CCCCCCCCCCCCCCCC -C -C TBF -C -CCCCCCCCCCCCCCCC - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF - END IF - RETURN - END - - - diff --git a/base/serial/csr/Makefile b/base/serial/csr/Makefile deleted file mode 100644 index d8b458704..000000000 --- a/base/serial/csr/Makefile +++ /dev/null @@ -1,43 +0,0 @@ -include ../../../Make.inc - -# -# The object files -# - -FOBJS = ccrnrmi.o ccsrmm.o ccsrrws.o ccsrsm.o csrmv.o csrsv.o ccsrck.o\ - zcrnrmi.o zcsrmm.o zcsrrws.o zcsrsm.o zsrmv.o zsrsv.o zcsrck.o - -#dcsrck.o dcsrmm.o dcsrsm.o dcsrmv.o dcsrsv.o dcrnrmi.o \ -# dcsrmv4.o dcsrmv2.o dcsrmv3.o dcsrrws.o\ -# scsrmm.o scsrmv.o scsrmv2.o scsrmv3.o scsrmv4.o scsrsm.o scsrsv.o\ -# scrnrmi.o \ - -OBJS=$(FOBJS) - -# -# Where the library should go, and how it is called. -# Note that we are regenerating most of libsparker.a on the fly. -SPARKERDIR=.. -LIBDIR=../.. -MODDIR=../../modules -FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG)$(SPARKERDIR) $(FMFLAG). -LIBFILE=$(LIBDIR)/$(LIBNAME) - -# -# No change should be needed below -# - - -default: lib - -lib: $(OBJS) - $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) - $(RANLIB) $(LIBDIR)/$(LIBNAME) - -clean: cleanobjs - -veryclean: cleanobjs - -cleanobjs: - /bin/rm -f $(OBJS) - diff --git a/base/serial/csr/ccrnrmi.f b/base/serial/csr/ccrnrmi.f deleted file mode 100644 index 0493af2c8..000000000 --- a/base/serial/csr/ccrnrmi.f +++ /dev/null @@ -1,64 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C - FUNCTION CCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_spk_) ccrnrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - complex(psb_spk_) A(*) -C .. Local scalars .. - INTEGER I, J - real(psb_spk_) NRMI, SUM - - NRMI = 0.D0 - DO I = 1, M - SUM = 0.D0 - DO J = IA2(I), IA2(I+1)-1 -C -C .. definition coerent abs -C -C SUM = SUM + ABS(A(J)) -C -C .. essl_way abs -C - SUM = SUM + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - NRMI = MAX(NRMI, SUM) - ENDDO - - CCRNRMI = NRMI - END diff --git a/base/serial/csr/ccsrck.f b/base/serial/csr/ccsrck.f deleted file mode 100644 index 116cf1119..000000000 --- a/base/serial/csr/ccsrck.f +++ /dev/null @@ -1,165 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Purpose -C ======= -C -C Performing checks on sparse matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will use -C matrix P or the transpose of P for the permutation as follows: -C TRANS = 'N' -> permute with matrix P -C TRANS = 'T' or 'C' -> permute the transpose of P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C DESCRA - CHARACTER*5 array of DIMENSION (10) -C On entry DESCRA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPRP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit specify the error code. -C IERROR = 0 no errors -C IERROR > 0 error in integrity check - SUBROUTINE CCSRCK(TRANS,M,N,DESCRA,A,IA1,IA2, - + WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LWORK,M, N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - complex(psb_spk_) A(*), WORK(*) - INTEGER IA1(*), IA2(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J, nrow, nind -C -C .. Executable Statements .. -C - -C -C Check #1: Character descriptor have valid values -C - IERROR = 0 - - IF ((psb_toupper(DESCRA(1:1)).NE.'G').AND. - + (psb_toupper(DESCRA(1:1)).NE.'S').AND. - + (psb_toupper(DESCRA(1:1)).NE.'H').AND. - + (psb_toupper(DESCRA(1:1)).NE.'T').AND. - + (psb_toupper(DESCRA(1:1)).NE.'A').AND. - + (psb_toupper(DESCRA(1:1)).NE.'D')) THEN - IERROR = 11 - GOTO 9999 - END IF - IF ((psb_toupper(DESCRA(2:2)).NE.'U').AND. - + (psb_toupper(DESCRA(2:2)).NE.'L')) THEN - IERROR = 12 - GOTO 9999 - END IF - IF ((psb_toupper(DESCRA(3:3)).NE.'U').AND. - + (psb_toupper(DESCRA(3:3)).NE.'N')) THEN - IERROR = 13 - GOTO 9999 - END IF -C -C Check #2: Pointers have non decreasing order -C - IF (IA2(1).LE.0) THEN - IERROR = 14 - GOTO 9999 - ENDIF - - NROW = 0 - DO 10 I = 1, M - IF (IA2(I) .GT. IA2(I+1)) THEN - NROW = NROW + 1 - END IF - 10 CONTINUE - IF (NROW .GT. 0) THEN - IERROR = 15 - GOTO 9999 - END IF -C -C Check #3: Indices are within problem dimension -C - NIND = 0 - DO 20 I = 1, M - DO 30 J = IA2(I), IA2(I+1) - 1 - IF ((IA1(J).LT.0) .OR. (IA1(J).GT.N)) THEN - NIND = NIND + 1 - END IF - 30 CONTINUE - 20 CONTINUE - IF (NIND .GT. 0) THEN - IERROR = 16 - GOTO 9999 - END IF - 9999 CONTINUE - RETURN - END diff --git a/base/serial/csr/ccsrmm.f b/base/serial/csr/ccsrmm.f deleted file mode 100644 index 51859831c..000000000 --- a/base/serial/csr/ccsrmm.f +++ /dev/null @@ -1,237 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE CCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, -C * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) -C -C Purpose -C ======= -C -C Computing C <-- ALPHA A B + BETA C or -C C <-- ALPHA At B + BETA C or -C C <-- ALPHA Atc B + BETA C -C Called by ZSWMM -C This routine calls kernel for CSR data structure. -C -C Parameters -C ========== -C -C TRANSA - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' -> use A' (transpose of matrix A) -C TRANS = 'C' -> use conjugate transpose of A -C Unchanged on exit. -C -C N.B.: M, K for C matrix -C M, N for A matrix -C N, K for B matrix -C In the calling subroutine, ZSWMM, it was: -C M, N for C matrix -C M, K for A matrix -C K, N for B matrix -C Check the parameters order! -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C AR - COMPLEX*16 array of DIMENSION (*) -C On entry AR specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C JA - INTEGER array of dimension (*) -C On entry JA holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA - INTEGER array of dimension (*) -C On entry IA holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - COMPLEX*16 matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying ZSWMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C - SUBROUTINE CCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - complex(psb_spk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N, LWORK - CHARACTER TRANSA -C .. Array Arguments .. - complex(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J - CHARACTER DIAG, TRANS - -C .. External Subroutines .. - EXTERNAL CSRMV -C .. Executable Statements .. -C -C -C IF (DESCRA(1).EQ.'G') TRANS = TRANSA -C -C .. Why to loose TRANSA for H, T, A matrices? -C - TRANS = TRANSA -C - IF ((psb_toupper(DESCRA(1:1)).EQ.'S').AND. - + (psb_toupper(DESCRA(2:2)).EQ.'U')) THEN - IF (psb_toupper(TRANSA).EQ.'C') THEN - TRANS = 'V' - ELSE - TRANS = 'U' - ENDIF - ENDIF - IF ((psb_toupper(DESCRA(1:1)).EQ.'S').AND. - + (psb_toupper(DESCRA(2:2)).EQ.'L')) THEN - IF (psb_toupper(TRANSA).EQ.'C') THEN - TRANS = 'M' - ELSE - TRANS = 'L' - ENDIF - ENDIF - -C .. Diagonal matrix - IF (psb_toupper(DESCRA(1:1)).EQ.'D') THEN -C .. Diagonal matrix with unitary values - IF (psb_toupper(DESCRA(3:3)).EQ.'U') THEN - DO 40 I = 1, K - DO 20 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) - 20 CONTINUE - 40 CONTINUE - RETURN -C .. Diagonal matrix to be conjugated - ELSE IF (psb_toupper(TRANSA).EQ.'C') THEN - DO 80 I = 1, K - DO 60 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA * - + CONJG(AR(J)) * B(J,I) - 60 CONTINUE - 80 CONTINUE - RETURN -C .. Generic diagonal matrix - ELSE - DO 91 I = 1, K - DO 90 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA * - + AR(J) * B(J,I) - 90 CONTINUE - 91 CONTINUE - RETURN - ENDIF - END IF -C - IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' - IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' -C -C C = A*B or C=A'*B or C=conjug(A')*B -C -C TRANS = -C 'N': Compute using A as it is. -C 'T': Compute using the transpose of A. -C 'C': Compute using conjugate transpose of A. -C 'U': A is symmetric, stored upper, compute as it is; -C (transposition makes no sense) -C 'V': A is symmetric, stored upper, to be conjugated. -C 'L': A is symmetric, stored lower, compute as it is. -C 'M': A is symmetric, stored lower, to be conjugated. -C DIAG = -C 'U': Unitary diagonal. -C 'N': Generic diagonal. - -C - DO 100 I = 1, K - CALL CSRMV(TRANS,DIAG,M,N,ALPHA,AR,JA,IA,B(1,I), - + BETA,C(1,I),WORK) - 100 CONTINUE - RETURN - END - diff --git a/base/serial/csr/ccsrrws.f b/base/serial/csr/ccsrrws.f deleted file mode 100644 index 96433b735..000000000 --- a/base/serial/csr/ccsrrws.f +++ /dev/null @@ -1,70 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C - SUBROUTINE CCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - complex(psb_spk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER I, J - real(psb_spk_) SUM - - IF (psb_toupper(TRANS).EQ.'N') THEN - DO I = 1, M - ROWSUM(I) = (0.0D0, 0.0D0) - DO J = IA2(I), IA2(I + 1) - 1 - ROWSUM(I) = ROWSUM(I) + - + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - ENDDO - ELSE IF ((psb_toupper(TRANS).EQ.'T').OR. - + (psb_toupper(TRANS).EQ.'C')) THEN - DO J = 1, N - ROWSUM(J) = (0.0D0, 0.0D0) - ENDDO - DO I = 1, M - DO J = IA2(I), IA2(I + 1) - 1 - ROWSUM(IA1(J)) = ROWSUM(IA1(J)) + - + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - ENDDO - ENDIF - END - - - diff --git a/base/serial/csr/ccsrsm.f b/base/serial/csr/ccsrsm.f deleted file mode 100644 index ff6605f57..000000000 --- a/base/serial/csr/ccsrsm.f +++ /dev/null @@ -1,118 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE CCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, - * B,LDB,BETA,C,LDC,WORK,LWORK) - use psb_const_mod - use psb_string_mod - complex(psb_spk_) ALPHA, BETA - INTEGER LDB, LDC, LWORK, M, N - CHARACTER UNITD, TRANST - complex(psb_spk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 - INTEGER I, K - CHARACTER DIAG, UPLO - -C .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5),err_act - - NAME = 'CCSRSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - int_Val(1)=0 - UPLO = '?' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' - IF (UPLO.EQ.'?') THEN - int_val(1) = 7 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' - IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' - IF(psb_toupper(UNITD).EQ.'B') THEN - IERROR=5 - int_val(1) = 4 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF (psb_toupper(UNITD).EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE - END IF - - if ((alpha.ne.(1.d0,0.d0)) .or.(beta .ne.(0.0d0,0.d0))) then - if (lwork .lt. m) then - int_val(1) = 17 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - DO I = 1, N - CALL CSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),work) - do k=1,m - c(k,i) = beta*c(k,i) + alpha*work(k) - enddo - enddo - else - DO I = 1, N - CALL CSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),c(1,i)) - enddo - endif - IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/csr/csrmv.f b/base/serial/csr/csrmv.f deleted file mode 100644 index dd0bddf58..000000000 --- a/base/serial/csr/csrmv.f +++ /dev/null @@ -1,562 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -*********************************************************************** -* CSRMV modified for SPARKER * -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = conjug(A') or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* ZCSRMM * -* * -* ENTRY-POINT = CSRMV * -* * -* * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'C' 'L' 'M' 'U' 'V' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'C' , OP( A ) = conjug(A') * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* TRANS = 'M' or 'V', op( A ) = lower or * -* upper part of conjugate of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: COMPLEX*16. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: COMPLEX*16: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: COMPLEX*16 ARRAY(N) * -* (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: COMPLEX*16. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: COMPLEX*16 ARRAY(M) * -* (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: COMPLEX*16 ARRAY(M) * -* (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: COMPLEX*16 ARRAY(M) * -* (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** -C - SUBROUTINE CSRMV (TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,BETA,Y,WORK) - use psb_const_mod - use psb_string_mod -C .. Parameters .. - complex(psb_spk_) ONE, ZERO - PARAMETER (ONE=(1.0, 0.0), ZERO=(0.0, 0.0)) -C .. Scalar Arguments .. - complex(psb_spk_) ALPHA, BETA - INTEGER M, N - CHARACTER DIAG, TRANS -C .. Array Arguments .. - complex(psb_spk_) AS(*), WORK(*), X(*), Y(*) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - complex(psb_spk_) ACC - INTEGER I, J, K, NCOLA, NROWA,DUM - LOGICAL SYM, TRA, COTRA, UNI -C .. Executable Statements .. -C - UNI = psb_toupper(DIAG).EQ.'U' -C -C .. Not simmetric matrix - TRA = psb_toupper(TRANS).EQ.'T' - COTRA = psb_toupper(TRANS).EQ.'C' - -C .. Symmetric matrix upper or lower - SYM = (psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U').OR. - + (psb_toupper(TRANS).EQ.'M').OR. - + (psb_toupper(TRANS).EQ.'V') -C - IF (.NOT.(TRA.OR.COTRA)) THEN - NROWA = M - NCOLA = N - ELSE - NROWA = N - NCOLA = M - END IF !(....(CO)TRA) - - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, M - Y(I) = ZERO - ENDDO - ELSE - DO 20 I = 1, M - Y(I) = BETA*Y(I) - 20 CONTINUE - ENDIF - RETURN - END IF - -C - IF (SYM) THEN - IF (UNI) THEN -C -C ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - IF (BETA.NE.ZERO) THEN - DO 40 I = 1, M -C -C Product for diagonal elements -C - Y(I) = BETA*Y(I) + ALPHA*X(I) - 40 CONTINUE - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C Product for other elements - IF ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) THEN - DO 80 I = 1, M - ACC = ZERO - DO 60 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ACC = ACC + AS(J)*X(K) - 60 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 80 CONTINUE - ELSE ! Perform computations on conjug(A) - DO 82 I = 1, M - ACC = ZERO - DO 81 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) - ACC = ACC + CONJG(AS(J)) * X(K) - 81 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 82 CONTINUE - ENDIF -C - ELSE IF ( .NOT. UNI) THEN -C -C Check if matrix is lower or upper -C - IF ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'M')) THEN -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - IF (BETA.NE.ZERO) THEN - DO 100 I = 1, M - Y(I) = BETA*Y(I) - 100 CONTINUE - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - IF (psb_toupper(TRANS).EQ.'L') THEN - DO 140 I = 1, M - ACC = ZERO - DO 120 J = IA(I), IA(I+1) - 1 ! it was -2 - K = JA(J) -C -C To be optimized -C - IF (K.NE.I) THEN !for symmetric element - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ENDIF - ACC = ACC + AS(J)*X(K) - 120 CONTINUE - - Y(I) = Y(I) + ALPHA*ACC - 140 CONTINUE - ELSE ! Perform computations on conjug(A) - DO 142 I = 1, M - ACC = ZERO - DO 141 J = IA(I), IA(I+1) - 1 ! it was -2 - K = JA(J) -C -C To be optimized -C - IF (K.NE.I) THEN !for symmetric element - Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) - ENDIF - ACC = ACC + CONJG(AS(J)) * X(K) - 141 CONTINUE - Y(I) = Y(I) + ALPHA * ACC - 142 CONTINUE - - ENDIF - - ELSE ! ....Trans<>L, M -C -C UPPER CASE -C ....OK!! -C - IF (BETA.NE.ZERO) THEN - DO 160 I = 1, M - Y(I) = BETA*Y(I) - 160 CONTINUE - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - IF (psb_toupper(TRANS).EQ.'U') THEN - DO 200 I = 1, M - ACC = ZERO - DO 180 J = IA(I) , IA(I+1) - 1 ! removed +1 - K = JA(J) -C -C To be optimized -C - IF(K.NE.I) THEN - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ENDIF - ACC = ACC + AS(J)*X(K) - 180 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 200 CONTINUE - ELSE ! Perform computations on conjug(A) - DO 202 I = 1, M - ACC = ZERO - DO 201 J = IA(I) , IA(I+1) - 1 ! removed +1 - K = JA(J) -C -C To be optimized -C - IF(K.NE.I) THEN - Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) - ENDIF - ACC = ACC + CONJG(AS(J)) * X(K) - 201 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 202 CONTINUE - ENDIF - END IF ! ......TRANS=='L' - END IF ! ......Not UNI -C - ELSE IF ((.NOT.TRA).AND.(.NOT.COTRA)) THEN !......NOT SYM - - IF ( .NOT. UNI) THEN -C -C .......General Not Unit, No Traspose -C - - IF (BETA.NE.ZERO) THEN - DO 240 I = 1, M - ACC = ZERO - DO 220 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 220 CONTINUE - Y(I) = ALPHA*ACC + BETA*Y(I) - 240 CONTINUE - ELSE - DO I = 1, M - ACC = ZERO - DO J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - ENDDO - Y(I) = ALPHA*ACC - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO 280 I = 1, M - ACC = ZERO - DO 260 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 260 CONTINUE - Y(I) = ALPHA*(ACC+X(I)) + BETA*Y(I) - 280 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - ACC = ZERO - DO J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - ENDDO - Y(I) = ALPHA*(ACC+X(I)) - ENDDO - ENDIF - END IF !....End Testing on UNI -C - ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO 300 I = 1, M - Y(I) = BETA*Y(I) - 300 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO 320 I = 1, M - Y(I) = BETA*Y(I) + ALPHA*X(I) - 320 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C - END IF !....UNI -C - IF (ALPHA.EQ.ONE) THEN -C - DO 360 I = 1, N - DO 340 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + AS(J)*X(I) - 340 CONTINUE - 360 CONTINUE -C - ELSE IF (ALPHA.EQ.-ONE) THEN -C - DO 400 I = 1, n - DO 380 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) - AS(J)*X(I) - 380 CONTINUE - 400 CONTINUE -C - ELSE !.....Else on TRA -C -C This work array is used for efficiency -C - DO 420 I = 1, N - WORK(I) = ALPHA*X(I) - 420 CONTINUE -C - DO 460 I = 1, n - DO 440 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + AS(J)*WORK(I) - 440 CONTINUE - 460 CONTINUE -C - END IF !.....End testing on ALPHA - - ELSE IF (COTRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO 500 I = 1, M - Y(I) = BETA*Y(I) - 500 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO 520 I = 1, M - Y(I) = BETA*Y(I) + ALPHA*X(I) - 520 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C - END IF !....UNI -C - IF (ALPHA.EQ.ONE) THEN -C - DO 560 I = 1, N - DO 540 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + CONJG(AS(J))*X(I) - 540 CONTINUE - 560 CONTINUE -C - ELSE IF (ALPHA.EQ.-ONE) THEN -C - DO 600 I = 1, n - DO 580 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) - CONJG(AS(J))*X(I) - 580 CONTINUE - 600 CONTINUE -C - ELSE !.....Else on TRA -C -C This work array is used for efficiency -C - DO 620 I = 1, N - WORK(I) = ALPHA*X(I) - 620 CONTINUE -C - DO 660 I = 1, n - DO 640 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + CONJG(AS(J))*WORK(I) - 640 CONTINUE - 660 CONTINUE -C - END IF !.....End testing on ALPHA - - END IF !.....End testing on SYM -C - RETURN -C -C END OF CSRMV -C - END - diff --git a/base/serial/csr/csrsv.f b/base/serial/csr/csrsv.f deleted file mode 100644 index 84f13f528..000000000 --- a/base/serial/csr/csrsv.f +++ /dev/null @@ -1,176 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C - SUBROUTINE CSRSV (UPLO,TRANS,DIAG,N,AS,JA,IA,B,X) - use psb_const_mod - use psb_string_mod - complex(psb_spk_) ZERO - PARAMETER (ZERO = (0.0, 0.0)) - INTEGER N - CHARACTER DIAG, TRANS, UPLO - complex(psb_spk_) AS(*), B(*), X(*) - INTEGER IA(*), JA(*) - complex(psb_spk_) ACC - INTEGER I, J, K - LOGICAL LOW, TRA, COTRA, UNI - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - COTRA = (psb_toupper(TRANS).EQ.'C') - LOW = (psb_toupper(UPLO).EQ.'L') - IF ((.NOT.TRA).AND.(.NOT.COTRA)) THEN - IF (LOW) THEN - IF (.NOT.UNI) THEN - DO 40 I = 1, N - ACC = ZERO - DO 20 J = IA(I), IA(I+1) - 2 - ACC = ACC + AS(J)*X(JA(J)) - 20 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I+1)-1) - 40 CONTINUE - ELSE IF (UNI) THEN - DO 80 I = 1, N - ACC = ZERO - DO 60 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 60 CONTINUE - X(I) = B(I) - ACC - 80 CONTINUE - END IF - ELSE IF (.NOT.LOW) THEN - IF (.NOT.UNI) THEN - DO 120 I = N, 1, -1 - ACC = ZERO - DO 100 J = IA(I) + 1, IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 100 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I)) - 120 CONTINUE - ELSE IF (UNI) THEN - DO 160 I = N, 1, -1 - ACC = ZERO - DO 140 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 140 CONTINUE - X(I) = B(I) - ACC - 160 CONTINUE - END IF - END IF - ELSE IF (TRA) THEN - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF (.NOT.UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF (.NOT.LOW) THEN - IF (.NOT.UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF - ELSE IF (COTRA) THEN - DO 580 I = 1, N - X(I) = B(I) - 580 CONTINUE - IF (LOW) THEN - IF (.NOT.UNI) THEN - DO 620 I = N, 1, -1 - X(I) = X(I)/CONJG(AS(IA(I+1)-1)) - ACC = X(I) - DO 600 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - CONJG(AS(J))*ACC - 600 CONTINUE - 620 CONTINUE - ELSE IF (UNI) THEN - DO 660 I = N, 1, -1 - ACC = X(I) - DO 640 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - CONJG(AS(J))*ACC - 640 CONTINUE - 660 CONTINUE - END IF - ELSE IF (.NOT.LOW) THEN - IF (.NOT.UNI) THEN - DO 700 I = 1, N - X(I) = X(I)/CONJG(AS(IA(I))) - ACC = X(I) - DO 680 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - CONJG(AS(J))*ACC - 680 CONTINUE - 700 CONTINUE - ELSE IF (UNI) THEN - DO 740 I = 1, N - ACC = X(I) - DO 720 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - CONJG(AS(J))*ACC - 720 CONTINUE - 740 CONTINUE - END IF - END IF - END IF - RETURN - END - - - diff --git a/base/serial/csr/dcrnrmi.f b/base/serial/csr/dcrnrmi.f deleted file mode 100644 index d7e871980..000000000 --- a/base/serial/csr/dcrnrmi.f +++ /dev/null @@ -1,63 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute Infinity norm for sparse matrix in CSR Format ... - FUNCTION DCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) dcrnrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_dpk_) A(*) -C .. Local scalars .. - INTEGER I, J - real(psb_dpk_) NRMI, SUM - - IERROR=0 - NRMI = 0.0 - DO I = 1, M - SUM = 0.0 - DO J = IA2(I), IA2(I+1)-1 - SUM = SUM + ABS(A(J)) - ENDDO - - IF (SUM.GT.NRMI) THEN - NRMI = SUM - ENDIF - ENDDO - - DCRNRMI = NRMI - END diff --git a/base/serial/csr/dcsrck.f b/base/serial/csr/dcsrck.f deleted file mode 100644 index 00d0e9733..000000000 --- a/base/serial/csr/dcsrck.f +++ /dev/null @@ -1,167 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Purpose -C ======= -C -C Performing checks on sparse matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will use -C matrix P or the transpose of P for the permutation as follows: -C TRANS = 'N' -> permute with matrix P -C TRANS = 'T' or 'C' -> permute the transpose of P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C DESCRA - CHARACTER*5 array of DIMENSION (10) -C On entry DESCRA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPRP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit specify the error code. -C IERROR = 0 no errors -C IERROR > 0 error in integrity check - - - SUBROUTINE DCSRCK(TRANS,M,N,DESCRA,A,IA1,IA2, - + WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LWORK,M, N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - real(psb_dpk_) A(*), WORK(*) - INTEGER IA1(*), IA2(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J, nrow, nind -C -C .. Executable Statements .. -C - -C -C Check #1: Character descriptor have valid values -C - IERROR = 0 - - IF ((psb_toupper(DESCRA(1:1)).NE.'G').AND. - + (psb_toupper(DESCRA(1:1)).NE.'S').AND. - + (psb_toupper(DESCRA(1:1)).NE.'H').AND. - + (psb_toupper(DESCRA(1:1)).NE.'T').AND. - + (psb_toupper(DESCRA(1:1)).NE.'A').AND. - + (psb_toupper(DESCRA(1:1)).NE.'D')) THEN - IERROR = 11 - GOTO 9999 - END IF - IF ((psb_toupper(DESCRA(2:2)).NE.'U').AND. - + (psb_toupper(DESCRA(2:2)).NE.'L')) THEN - IERROR = 12 - GOTO 9999 - END IF - IF ((psb_toupper(DESCRA(3:3)).NE.'U').AND. - + (psb_toupper(DESCRA(3:3)).NE.'N')) THEN - IERROR = 13 - GOTO 9999 - END IF -C -C Check #2: Pointers have non decreasing order -C - IF (IA2(1).LE.0) THEN - IERROR = 14 - GOTO 9999 - ENDIF - - NROW = 0 - DO 10 I = 1, M - IF (IA2(I) .GT. IA2(I+1)) THEN - NROW = NROW + 1 - END IF - 10 CONTINUE - IF (NROW .GT. 0) THEN - IERROR = 15 - GOTO 9999 - END IF -C -C Check #3: Indices are within problem dimension -C - NIND = 0 - DO 20 I = 1, M - DO 30 J = IA2(I), IA2(I+1) - 1 - IF ((IA1(J).LT.0) .OR. (IA1(J).GT.N)) THEN - NIND = NIND + 1 - END IF - 30 CONTINUE - 20 CONTINUE - IF (NIND .GT. 0) THEN - IERROR = 16 - GOTO 9999 - END IF - 9999 CONTINUE - RETURN - END diff --git a/base/serial/csr/dcsrmm.f b/base/serial/csr/dcsrmm.f deleted file mode 100644 index 01eb908c8..000000000 --- a/base/serial/csr/dcsrmm.f +++ /dev/null @@ -1,147 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -c -c What if a wrong DESCRA is passed? -c -c -* -* - SUBROUTINE DCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - real(psb_dpk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N, LWORK,IERROR - CHARACTER TRANSA -C .. Array Arguments .. - real(psb_dpk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J, K4 - CHARACTER DIAG, TRANS -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - -C .. External Subroutines .. - EXTERNAL DCSRMV -C .. Executable Statements .. -C -C - NAME = 'DCSRMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) -C - IF (psb_toupper(DESCRA(1:1)).EQ.'G') TRANS = TRANSA - IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') TRANS = 'U' - IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') TRANS = 'L' -c -c Does DSRMV manage this case too? -c - IF (psb_toupper(DESCRA(1:1)).EQ.'D') THEN - IF (psb_toupper(DESCRA(3:3)).EQ.'U') THEN - DO 40 I = 1, K - DO 20 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) - 20 CONTINUE - 40 CONTINUE - ELSE - DO 80 I = 1, K - DO 60 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*AR(J)*B(J,I) - 60 CONTINUE - 80 CONTINUE - END IF - RETURN - END IF -C - IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' - IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' -C -C C = A*B OR C=A'*B -C -C - NB = 4 - K4 = MOD(K,NB) - SELECT CASE(K4) - CASE(1) - IF (K==1) THEN - CALL DCSRMV(TRANS,DIAG,M,N,ALPHA,AR,JA,IA,B(1,1), - + BETA,C(1,1),WORK,LWORK,IERROR) - ELSE - CALL DCSRMV2(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) - CALL DCSRMV3(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,3),LDB,BETA,C(1,3),LDC,WORK,LWORK,IERROR) - K4 = K4 + 4 - ENDIF - CASE(2) - CALL DCSRMV2(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) - CASE(3) - CALL DCSRMV3(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) - END SELECT - - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - DO I=K4+1,K,NB - CALL DCSRMV4(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,I),LDB,BETA,C(1,I),LDC,WORK,LWORK,IERROR) - ENDDO - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/csr/dcsrmv.f b/base/serial/csr/dcsrmv.f deleted file mode 100644 index db6e15381..000000000 --- a/base/serial/csr/dcsrmv.f +++ /dev/null @@ -1,527 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* DSRMV modified for SPARKER -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* DSMMV * -* * -* ENTRY-POINT = DSRMV * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'L' 'U' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE DCSRMV(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,BETA,Y, - + WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - real(psb_dpk_) ALPHA, BETA - INTEGER M, N,LWORK,IERROR - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_dpk_) AS(*), WORK(*), X(*), Y(*) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - real(psb_dpk_) ACC - INTEGER I, J, K, NCOLA, NROWA - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR = 0 - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) -C - IF ( .NOT. TRA) THEN - NROWA = M - NCOLA = N - ELSE IF (TRA) THEN - NROWA = N - NCOLA = M - END IF !(....TRA) - - IF (ALPHA.EQ.DZERO) THEN - IF (BETA.EQ.DZERO) THEN - DO I = 1, M - Y(I) = DZERO - ENDDO - ELSE - DO 20 I = 1, M - Y(I) = BETA*Y(I) - 20 CONTINUE - ENDIF - RETURN - END IF - -C - IF (SYM) THEN - IF (UNI) THEN -C -C ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - IF (BETA.NE.DZERO) THEN - DO 40 I = 1, M -C -C Product for diagonal elements -C - Y(I) = BETA*Y(I) + ALPHA*X(I) - 40 CONTINUE - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C Product for other elements - DO 80 I = 1, M - ACC = DZERO - DO 60 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ACC = ACC + AS(J)*X(K) - 60 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 80 CONTINUE -C - ELSE IF ( .NOT. UNI) THEN -C -C Check if matrix is lower or upper -C - IF (PSB_TOUPPER(TRANS).EQ.'L') THEN -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - IF (BETA.NE.DZERO) THEN - DO 100 I = 1, M - Y(I) = BETA*Y(I) - 100 CONTINUE - ELSE - DO I = 1, M - Y(I) = DZERO - ENDDO - ENDIF - - DO 140 I = 1, M - ACC = DZERO - DO 120 J = IA(I), IA(I+1) - 1 ! it was -2 - K = JA(J) -C -C To be optimized -C - IF (K.NE.I) THEN !for symmetric element - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ENDIF - ACC = ACC + AS(J)*X(K) - 120 CONTINUE - - Y(I) = Y(I) + ALPHA*ACC - 140 CONTINUE - ELSE ! ....Trans<>L -C -C UPPER CASE -C ....OK!! -C - IF (BETA.NE.DZERO) THEN - DO 160 I = 1, M - Y(I) = BETA*Y(I) - 160 CONTINUE - ELSE - DO I = 1, M - Y(I) = DZERO - ENDDO - ENDIF - - DO 200 I = 1, M - ACC = DZERO - DO 180 J = IA(I) , IA(I+1) - 1 ! removed +1 - K = JA(J) -C -C To be optimized -C - IF(K.NE.I) THEN - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ENDIF - ACC = ACC + AS(J)*X(K) - 180 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 200 CONTINUE - END IF ! ......TRANS=='L' - END IF ! ......Not UNI -C - ELSE IF ( .NOT. TRA) THEN !......NOT SYM - - IF ( .NOT. UNI) THEN -C -C .......General Not Unit, No Traspose -C - if (beta == dzero) then - if (alpha==done) then - do i = 1, m - acc = dzero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else if (alpha==-done) then - do i = 1, m - acc = dzero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else - do i = 1, m - acc = dzero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = alpha*acc - enddo - - endif - - else if (beta==done) then - - if (alpha==done) then - do i = 1, m - acc = y(i) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else if (alpha==-done) then - do i = 1, m - acc = y(i) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else - do i = 1, m - acc = dzero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = alpha*acc + y(i) - enddo - endif - - else if (beta==-done) then - - if (alpha==done) then - do i = 1, m - acc = -y(i) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else if (alpha==-done) then - do i = 1, m - acc = -y(i) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else - do i = 1, m - acc = dzero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = alpha*acc - y(i) - enddo - endif - else - if (alpha==done) then - do i = 1, m - acc = dzero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = acc + beta*y(i) - enddo - else if (alpha==-done) then - do i = 1, m - acc = dzero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j)) - enddo - y(i) = acc + beta*y(i) - enddo - else - do i = 1, m - acc = dzero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = alpha*acc + beta*y(i) - enddo - endif - end if -C - ELSE IF (UNI) THEN -C - IF (BETA.NE.DZERO) THEN - DO 280 I = 1, M - ACC = DZERO - DO 260 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 260 CONTINUE - Y(I) = ALPHA*(ACC+X(I)) + BETA*Y(I) - 280 CONTINUE - ELSE !(BETA.EQ.DZERO) - DO I = 1, M - ACC = DZERO - DO J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - ENDDO - Y(I) = ALPHA*(ACC+X(I)) - ENDDO - ENDIF - END IF !....End Testing on UNI -C - ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.DZERO) THEN - DO 300 I = 1, M - Y(I) = BETA*Y(I) - 300 CONTINUE - ELSE !(BETA.EQ.DZERO) - DO I = 1, M - Y(I) = DZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.DZERO) THEN - DO 320 I = 1, M - Y(I) = BETA*Y(I) + ALPHA*X(I) - 320 CONTINUE - ELSE !(BETA.EQ.DZERO) - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C - END IF !....UNI -C - IF (ALPHA.EQ.DONE) THEN -C - DO 360 I = 1, N - DO 340 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + AS(J)*X(I) - 340 CONTINUE - 360 CONTINUE -C - ELSE IF (ALPHA.EQ.-DONE) THEN -C - DO 400 I = 1, n - DO 380 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) - AS(J)*X(I) - 380 CONTINUE - 400 CONTINUE -C - ELSE !.....Else on TRA -C -C This work array is used for efficiency -C - IF (LWORK.LT.N) THEN - IERROR = 60 - WORK(1) = DBLE(N) - RETURN - ENDIF - DO 420 I = 1, N - WORK(I) = ALPHA*X(I) - 420 CONTINUE -C - DO 460 I = 1, n - DO 440 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + AS(J)*WORK(I) - 440 CONTINUE - 460 CONTINUE -C - END IF !.....End testing on ALPHA - - END IF !.....End testing on SYM -C - RETURN -C -C END OF DSRMV -C - END - diff --git a/base/serial/csr/dcsrmv2.f b/base/serial/csr/dcsrmv2.f deleted file mode 100644 index 1fff2923b..000000000 --- a/base/serial/csr/dcsrmv2.f +++ /dev/null @@ -1,533 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* DSRMV modified for SPARKER -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* DSMMV * -* * -* ENTRY-POINT = DSRMV * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'L' 'U' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE DCSRMV2(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, - + BETA,Y,LDY, WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - integer nb - parameter (nb=2) -C .. Parameters .. - real(psb_dpk_) ONE, ZERO - PARAMETER (ONE=1.0D0,ZERO=0.0D0) -C .. Scalar Arguments .. - real(psb_dpk_) ALPHA, BETA - INTEGER M, N,LWORK,IERROR,ldx,ldy - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - real(psb_dpk_) ACC(nb) - INTEGER I, J, K, NCOLA, NROWA - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR = 0 - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) -C - if ( .not. tra) then - nrowa = m - ncola = n - else if (tra) then - nrowa = n - ncola = m - end if !(....tra) - - if (alpha.eq.zero) then - if (beta.eq.zero) then - do i = 1, m - y(i,1:nb) = zero - enddo - else - do 20 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 20 continue - endif - return - end if - -c - if (sym) then - if (uni) then -c -c ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - if (beta.ne.zero) then - do i = 1, m -C -C Product for diagonal elements -c - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - enddo - else - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -C Product for other elements - do 80 i = 1, m - acc = zero - do 60 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 60 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 80 continue -C - else if ( .not. uni) then -C -C Check if matrix is lower or upper -C - if (trans.eq.'L') then -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - if (beta.ne.zero) then - do 100 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 100 continue - else - do i = 1, m - y(i,1:nb) = zero - enddo - endif - - do 140 i = 1, m - acc = zero - do 120 j = ia(i), ia(i+1) - 1 ! it was -2 - K = ja(j) -C -C To be optimized -C - if (k.ne.i) then !for symmetric element - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 120 continue - - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 140 continue - else ! ....Trans<>L -C -C UPPER CASE -C ....OK!! -C - if (beta.ne.zero) then - do 160 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 160 continue - else - do i = 1, m - y(i,1:nb) = zero - enddo - endif - - do 200 i = 1, m - acc = zero - do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 - k = ja(j) -C -C To be optimized -C - if (k.ne.i) then - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 180 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 200 continue - end if ! ......TRANS=='L' - end if ! ......Not UNI -c - else if ( .not. tra) then !......NOT SYM - - if ( .not. uni) then -C -C .......General Not Unit, No Traspose -C - - if (beta == zero) then - if (alpha==one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - enddo - - endif - - else if (beta==one) then - - if (alpha==one) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + y(i,1:nb) - enddo - endif - - else if (beta==-one) then - - if (alpha==one) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - y(i,1:nb) - enddo - endif - else - if (alpha==one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else if (alpha==-one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + beta*y(i,1:nb) - enddo - endif - end if -c - else if (uni) then -c - if (beta.ne.zero) then - do 280 i = 1, m - acc(1:nb) = zero - do 260 j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - 260 continue - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) - 280 continue - else !(beta.eq.zero) - do i = 1, m - acc(1:nb) = zero - do j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) - enddo - endif - end if !....End Testing on UNI -C - else if (tra) then !....Else on SYM (swapped M and N) -C - if ( .not. uni) then -c - if (beta.ne.zero) then - do 300 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 300 continue - else !(BETA.EQ.ZERO) - do i = 1, m - y(i,1:nb) = zero - enddo - endif -c - else if (uni) then -c - - if (beta.ne.zero) then - do 320 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - 320 continue - else !(BETA.EQ.ZERO) - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -c - end if !....UNI -C - if (alpha.eq.one) then -c - do 360 i = 1, n - do 340 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) - 340 continue - 360 continue -c - else if (alpha.eq.-one) then -c - do 400 i = 1, n - do 380 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) - 380 continue - 400 continue -c - else !.....Else on TRA -C -C This work array is used for efficiency -C - if (lwork.lt.n) then - ierror = 60 - work(1) = dble(n) - return - endif -c$$$ do 420 i = 1, n -c$$$ work(i) = alpha*x(i,1:4) -c$$$ 420 continue -c$$$C -c$$$ DO 460 I = 1, n -c$$$ DO 440 J = IA(I), IA(I+1) - 1 -c$$$ K = JA(J) -c$$$ Y(K) = Y(K) + AS(J)*WORK(I) -c$$$ 440 CONTINUE -c$$$ 460 CONTINUE -c - end if !.....end testing on alpha - - end if !.....end testing on sym -c - return -c -c end of dsrmv -c - end - diff --git a/base/serial/csr/dcsrmv3.f b/base/serial/csr/dcsrmv3.f deleted file mode 100644 index 3ac345145..000000000 --- a/base/serial/csr/dcsrmv3.f +++ /dev/null @@ -1,532 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* DSRMV modified for SPARKER -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* DSMMV * -* * -* ENTRY-POINT = DSRMV * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'L' 'U' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE DCSRMV3(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, - + BETA,Y,LDY, WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - integer nb - parameter (nb=3) -C .. Parameters .. - real(psb_dpk_) ONE, ZERO - PARAMETER (ONE=1.0D0,ZERO=0.0D0) -C .. Scalar Arguments .. - real(psb_dpk_) ALPHA, BETA - INTEGER M, N,LWORK,IERROR,ldx,ldy - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - real(psb_dpk_) ACC(nb) - INTEGER I, J, K, NCOLA, NROWA - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR = 0 - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) -C - if ( .not. tra) then - nrowa = m - ncola = n - else if (tra) then - nrowa = n - ncola = m - end if !(....tra) - - if (alpha.eq.zero) then - if (beta.eq.zero) then - do i = 1, m - y(i,1:nb) = zero - enddo - else - do 20 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 20 continue - endif - return - end if - -c - if (sym) then - if (uni) then -c -c ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - if (beta.ne.zero) then - do i = 1, m -C -C Product for diagonal elements -c - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - enddo - else - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -C Product for other elements - do 80 i = 1, m - acc = zero - do 60 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 60 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 80 continue -C - else if ( .not. uni) then -C -C Check if matrix is lower or upper -C - if (trans.eq.'L') then -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - if (beta.ne.zero) then - do 100 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 100 continue - else - do i = 1, m - y(i,1:nb) = zero - enddo - endif - - do 140 i = 1, m - acc = zero - do 120 j = ia(i), ia(i+1) - 1 ! it was -2 - K = ja(j) -C -C To be optimized -C - if (k.ne.i) then !for symmetric element - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 120 continue - - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 140 continue - else ! ....Trans<>L -C -C UPPER CASE -C ....OK!! -C - if (beta.ne.zero) then - do 160 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 160 continue - else - do i = 1, m - y(i,1:nb) = zero - enddo - endif - - do 200 i = 1, m - acc = zero - do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 - k = ja(j) -C -C To be optimized -C - if (k.ne.i) then - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 180 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 200 continue - end if ! ......TRANS=='L' - end if ! ......Not UNI -c - else if ( .not. tra) then !......NOT SYM - - if ( .not. uni) then -C -C .......General Not Unit, No Traspose -C - if (beta == zero) then - if (alpha==one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - enddo - - endif - - else if (beta==one) then - - if (alpha==one) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + y(i,1:nb) - enddo - endif - - else if (beta==-one) then - - if (alpha==one) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - y(i,1:nb) - enddo - endif - else - if (alpha==one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else if (alpha==-one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + beta*y(i,1:nb) - enddo - endif - end if -c - else if (uni) then -c - if (beta.ne.zero) then - do 280 i = 1, m - acc(1:nb) = zero - do 260 j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - 260 continue - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) - 280 continue - else !(beta.eq.zero) - do i = 1, m - acc(1:nb) = zero - do j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) - enddo - endif - end if !....End Testing on UNI -C - else if (tra) then !....Else on SYM (swapped M and N) -C - if ( .not. uni) then -c - if (beta.ne.zero) then - do 300 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 300 continue - else !(BETA.EQ.ZERO) - do i = 1, m - y(i,1:nb) = zero - enddo - endif -c - else if (uni) then -c - - if (beta.ne.zero) then - do 320 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - 320 continue - else !(BETA.EQ.ZERO) - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -c - end if !....UNI -C - if (alpha.eq.one) then -c - do 360 i = 1, n - do 340 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) - 340 continue - 360 continue -c - else if (alpha.eq.-one) then -c - do 400 i = 1, n - do 380 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) - 380 continue - 400 continue -c - else !.....Else on TRA -C -C This work array is used for efficiency -C - if (lwork.lt.n) then - ierror = 60 - work(1) = dble(n) - return - endif -c$$$ do 420 i = 1, n -c$$$ work(i) = alpha*x(i,1:4) -c$$$ 420 continue -c$$$C -c$$$ DO 460 I = 1, n -c$$$ DO 440 J = IA(I), IA(I+1) - 1 -c$$$ K = JA(J) -c$$$ Y(K) = Y(K) + AS(J)*WORK(I) -c$$$ 440 CONTINUE -c$$$ 460 CONTINUE -c - end if !.....end testing on alpha - - end if !.....end testing on sym -c - return -c -c end of dsrmv -c - end - diff --git a/base/serial/csr/dcsrmv4.f b/base/serial/csr/dcsrmv4.f deleted file mode 100644 index 1be6ccc68..000000000 --- a/base/serial/csr/dcsrmv4.f +++ /dev/null @@ -1,533 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* DSRMV modified for SPARKER -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* DSMMV * -* * -* ENTRY-POINT = DSRMV * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'L' 'U' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE DCSRMV4(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, - + BETA,Y,LDY, WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - integer nb - parameter (nb=4) -C .. Parameters .. - real(psb_dpk_) ONE, ZERO - PARAMETER (ONE=1.0D0,ZERO=0.0D0) -C .. Scalar Arguments .. - real(psb_dpk_) ALPHA, BETA - INTEGER M, N,LWORK,IERROR,ldx,ldy - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - real(psb_dpk_) ACC(nb) - INTEGER I, J, K, NCOLA, NROWA - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR = 0 - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) -C - if ( .not. tra) then - nrowa = m - ncola = n - else if (tra) then - nrowa = n - ncola = m - end if !(....tra) - - if (alpha.eq.zero) then - if (beta.eq.zero) then - do i = 1, m - y(i,1:nb) = zero - enddo - else - do 20 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 20 continue - endif - return - end if - -c - if (sym) then - if (uni) then -c -c ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - if (beta.ne.zero) then - do i = 1, m -C -C Product for diagonal elements -c - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - enddo - else - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -C Product for other elements - do 80 i = 1, m - acc = zero - do 60 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 60 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 80 continue -C - else if ( .not. uni) then -C -C Check if matrix is lower or upper -C - if (trans.eq.'L') then -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - if (beta.ne.zero) then - do 100 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 100 continue - else - do i = 1, m - y(i,1:nb) = zero - enddo - endif - - do 140 i = 1, m - acc = zero - do 120 j = ia(i), ia(i+1) - 1 ! it was -2 - K = ja(j) -C -C To be optimized -C - if (k.ne.i) then !for symmetric element - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 120 continue - - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 140 continue - else ! ....Trans<>L -C -C UPPER CASE -C ....OK!! -C - if (beta.ne.zero) then - do 160 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 160 continue - else - do i = 1, m - y(i,1:nb) = zero - enddo - endif - - do 200 i = 1, m - acc = zero - do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 - k = ja(j) -C -C To be optimized -C - if (k.ne.i) then - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 180 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 200 continue - end if ! ......TRANS=='L' - end if ! ......Not UNI -c - else if ( .not. tra) then !......NOT SYM - - if ( .not. uni) then -C -C .......General Not Unit, No Traspose -C - if (beta == zero) then - if (alpha==one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - enddo - - endif - - else if (beta==one) then - - if (alpha==one) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + y(i,1:nb) - enddo - endif - - else if (beta==-one) then - - if (alpha==one) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-one) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - y(i,1:nb) - enddo - endif - else - if (alpha==one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else if (alpha==-one) then - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else - do i = 1, m - acc = zero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + beta*y(i,1:nb) - enddo - endif - end if - -c - else if (uni) then -c - if (beta.ne.zero) then - do 280 i = 1, m - acc(1:nb) = zero - do 260 j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - 260 continue - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) - 280 continue - else !(beta.eq.zero) - do i = 1, m - acc(1:nb) = zero - do j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) - enddo - endif - end if !....End Testing on UNI -C - else if (tra) then !....Else on SYM (swapped M and N) -C - if ( .not. uni) then -c - if (beta.ne.zero) then - do 300 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 300 continue - else !(BETA.EQ.ZERO) - do i = 1, m - y(i,1:nb) = zero - enddo - endif -c - else if (uni) then -c - - if (beta.ne.zero) then - do 320 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - 320 continue - else !(BETA.EQ.ZERO) - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -c - end if !....UNI -C - if (alpha.eq.one) then -c - do 360 i = 1, n - do 340 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) - 340 continue - 360 continue -c - else if (alpha.eq.-one) then -c - do 400 i = 1, n - do 380 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) - 380 continue - 400 continue -c - else !.....Else on TRA -C -C This work array is used for efficiency -C - if (lwork.lt.n) then - ierror = 60 - work(1) = dble(n) - return - endif -c$$$ do 420 i = 1, n -c$$$ work(i) = alpha*x(i,1:4) -c$$$ 420 continue -c$$$C -c$$$ DO 460 I = 1, n -c$$$ DO 440 J = IA(I), IA(I+1) - 1 -c$$$ K = JA(J) -c$$$ Y(K) = Y(K) + AS(J)*WORK(I) -c$$$ 440 CONTINUE -c$$$ 460 CONTINUE -c - end if !.....end testing on alpha - - end if !.....end testing on sym -c - return -c -c end of dsrmv -c - end - diff --git a/base/serial/csr/dcsrrws.f b/base/serial/csr/dcsrrws.f deleted file mode 100644 index 9b53b9c50..000000000 --- a/base/serial/csr/dcsrrws.f +++ /dev/null @@ -1,68 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_dpk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER I, J - - IF (psb_toupper(TRANS).EQ.'N') THEN - DO I = 1, M - ROWSUM(I) = 0.0D0 - DO J = IA2(I), IA2(I + 1) - 1 - ROWSUM(I) = ROWSUM(I) + ABS(A(J)) - ENDDO - ENDDO - ELSE IF ((psb_toupper(TRANS).EQ.'T').OR. - + (psb_toupper(TRANS).EQ.'C')) THEN - DO J = 1, N - ROWSUM(J) = 0.0D0 - ENDDO - DO I = 1, M - DO J = IA2(I), IA2(I + 1) - 1 - ROWSUM(IA1(J)) = ROWSUM(IA1(J)) + ABS(A(J)) - ENDDO - ENDDO - ENDIF - END - - - diff --git a/base/serial/csr/dcsrsm.f b/base/serial/csr/dcsrsm.f deleted file mode 100644 index 111d9ec48..000000000 --- a/base/serial/csr/dcsrsm.f +++ /dev/null @@ -1,123 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, - * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - real(psb_dpk_) ALPHA, BETA - INTEGER LDB, LDC, LWORK, M, N, IERROR - CHARACTER UNITD, TRANST - real(psb_dpk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 - INTEGER I, K - CHARACTER DIAG, UPLO -C .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5), err_Act - - NAME = 'DCSRSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - int_Val(1)=0 - UPLO = '?' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' - IF (UPLO.EQ.'?') THEN - int_val(1) = 7 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - DIAG = 'N' - IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' - IF(UNITD.EQ.'B') THEN - IERROR=5 - int_val(1) = 4 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF (psb_toupper(UNITD).EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE - END IF - if ((alpha.ne.1.d0) .or.(beta .ne.0.0d0)) then - if (lwork .lt. m) then - int_val(1) = 17 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - DO I = 1, N - CALL DCSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),work) - do k=1,m - c(k,i) = beta*c(k,i) + alpha*work(k) - enddo - enddo - - else - DO 60 I = 1, N - CALL DCSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),C(1,I)) - 60 CONTINUE - endif - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/csr/dcsrsv.f b/base/serial/csr/dcsrsv.f deleted file mode 100644 index 6037c836d..000000000 --- a/base/serial/csr/dcsrsv.f +++ /dev/null @@ -1,133 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DCSRSV(UPLO,TRANS,DIAG,N,AS,JA,IA,B,X,IERROR) - use psb_const_mod - use psb_string_mod - real(psb_dpk_) ZERO - PARAMETER (ZERO=0.0D0) - INTEGER N, IERROR - CHARACTER DIAG, TRANS, UPLO - real(psb_dpk_) AS(*), B(*), X(*) - INTEGER IA(*), JA(*) - real(psb_dpk_) ACC - INTEGER I, J, K - LOGICAL LOW, TRA, UNI - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - LOW = (psb_toupper(UPLO).EQ.'L') - IF ( .NOT. TRA) THEN - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 40 I = 1, N - ACC = ZERO - DO 20 J = IA(I), IA(I+1) - 2 - ACC = ACC + AS(J)*X(JA(J)) - 20 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I+1)-1) - 40 CONTINUE - ELSE IF (UNI) THEN - DO 80 I = 1, N - ACC = ZERO - DO 60 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 60 CONTINUE - X(I) = B(I) - ACC - 80 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 120 I = N, 1, -1 - ACC = ZERO - DO 100 J = IA(I) + 1, IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 100 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I)) - 120 CONTINUE - ELSE IF (UNI) THEN - DO 160 I = N, 1, -1 - ACC = ZERO - DO 140 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 140 CONTINUE - X(I) = B(I) - ACC - 160 CONTINUE - END IF - END IF - ELSE IF (TRA) THEN - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF - END IF - RETURN - END - - - diff --git a/base/serial/csr/scrnrmi.f b/base/serial/csr/scrnrmi.f deleted file mode 100644 index c39780d33..000000000 --- a/base/serial/csr/scrnrmi.f +++ /dev/null @@ -1,63 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute Infinity norm for sparse matrix in CSR Format ... - FUNCTION SCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_spk_) scrnrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_spk_) A(*) -C .. Local scalars .. - INTEGER I, J - real(psb_dpk_) NRMI, SUM - - IERROR=0 - NRMI = 0.0 - DO I = 1, M - SUM = 0.0 - DO J = IA2(I), IA2(I+1)-1 - SUM = SUM + ABS(A(J)) - ENDDO - - IF (SUM.GT.NRMI) THEN - NRMI = SUM - ENDIF - ENDDO - - SCRNRMI = NRMI - END diff --git a/base/serial/csr/scsrmm.f b/base/serial/csr/scsrmm.f deleted file mode 100644 index e378d71f6..000000000 --- a/base/serial/csr/scsrmm.f +++ /dev/null @@ -1,144 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -c -c What if a wrong DESCRA is passed? -c -c -* -* - SUBROUTINE SCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - real(psb_spk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N, LWORK,IERROR - CHARACTER TRANSA -C .. Array Arguments .. - real(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J, K4 - CHARACTER DIAG, TRANS -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - -C -C - NAME = 'SCSRMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) -C - IF (psb_toupper(DESCRA(1:1)).EQ.'G') TRANS = TRANSA - IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') TRANS = 'U' - IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') TRANS = 'L' -c -c Does DSRMV manage this case too? -c - IF (psb_toupper(DESCRA(1:1)).EQ.'D') THEN - IF (psb_toupper(DESCRA(3:3)).EQ.'U') THEN - DO 40 I = 1, K - DO 20 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) - 20 CONTINUE - 40 CONTINUE - ELSE - DO 80 I = 1, K - DO 60 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*AR(J)*B(J,I) - 60 CONTINUE - 80 CONTINUE - END IF - RETURN - END IF -C - IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' - IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' -C -C C = A*B OR C=A'*B -C -C - NB = 4 - K4 = MOD(K,NB) - SELECT CASE(K4) - CASE(1) - IF (K==1) THEN - CALL SCSRMV(TRANS,DIAG,M,N,ALPHA,AR,JA,IA,B(1,1), - + BETA,C(1,1),WORK,LWORK,IERROR) - ELSE - CALL SCSRMV2(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) - CALL SCSRMV3(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,3),LDB,BETA,C(1,3),LDC,WORK,LWORK,IERROR) - K4 = K4 + 4 - ENDIF - CASE(2) - CALL SCSRMV2(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) - CASE(3) - CALL SCSRMV3(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,1),LDB,BETA,C(1,1),LDC,WORK,LWORK,IERROR) - END SELECT - - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - DO I=K4+1,K,NB - CALL SCSRMV4(TRANS,DIAG,M,N,ALPHA,AR,JA,IA, - + B(1,I),LDB,BETA,C(1,I),LDC,WORK,LWORK,IERROR) - ENDDO - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/csr/scsrmv.f b/base/serial/csr/scsrmv.f deleted file mode 100644 index 979176b7f..000000000 --- a/base/serial/csr/scsrmv.f +++ /dev/null @@ -1,527 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* DSRMV modified for SPARKER -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* DSMMV * -* * -* ENTRY-POINT = DSRMV * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'L' 'U' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE SCSRMV(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,BETA,Y, - + WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - real(psb_spk_) ALPHA, BETA - INTEGER M, N,LWORK,IERROR - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_spk_) AS(*), WORK(*), X(*), Y(*) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - real(psb_dpk_) ACC - INTEGER I, J, K, NCOLA, NROWA - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR = 0 - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) -C - IF ( .NOT. TRA) THEN - NROWA = M - NCOLA = N - ELSE IF (TRA) THEN - NROWA = N - NCOLA = M - END IF !(....TRA) - - IF (ALPHA.EQ.SZERO) THEN - IF (BETA.EQ.SZERO) THEN - DO I = 1, M - Y(I) = SZERO - ENDDO - ELSE - DO 20 I = 1, M - Y(I) = BETA*Y(I) - 20 CONTINUE - ENDIF - RETURN - END IF - -C - IF (SYM) THEN - IF (UNI) THEN -C -C ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - IF (BETA.NE.SZERO) THEN - DO 40 I = 1, M -C -C Product for diagonal elements -C - Y(I) = BETA*Y(I) + ALPHA*X(I) - 40 CONTINUE - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C Product for other elements - DO 80 I = 1, M - ACC = SZERO - DO 60 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ACC = ACC + AS(J)*X(K) - 60 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 80 CONTINUE -C - ELSE IF ( .NOT. UNI) THEN -C -C Check if matrix is lower or upper -C - IF (psb_toupper(TRANS).EQ.'L') THEN -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - IF (BETA.NE.SZERO) THEN - DO 100 I = 1, M - Y(I) = BETA*Y(I) - 100 CONTINUE - ELSE - DO I = 1, M - Y(I) = SZERO - ENDDO - ENDIF - - DO 140 I = 1, M - ACC = SZERO - DO 120 J = IA(I), IA(I+1) - 1 ! it was -2 - K = JA(J) -C -C To be optimized -C - IF (K.NE.I) THEN !for symmetric element - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ENDIF - ACC = ACC + AS(J)*X(K) - 120 CONTINUE - - Y(I) = Y(I) + ALPHA*ACC - 140 CONTINUE - ELSE ! ....Trans<>L -C -C UPPER CASE -C ....OK!! -C - IF (BETA.NE.SZERO) THEN - DO 160 I = 1, M - Y(I) = BETA*Y(I) - 160 CONTINUE - ELSE - DO I = 1, M - Y(I) = SZERO - ENDDO - ENDIF - - DO 200 I = 1, M - ACC = SZERO - DO 180 J = IA(I) , IA(I+1) - 1 ! removed +1 - K = JA(J) -C -C To be optimized -C - IF(K.NE.I) THEN - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ENDIF - ACC = ACC + AS(J)*X(K) - 180 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 200 CONTINUE - END IF ! ......TRANS=='L' - END IF ! ......Not UNI -C - ELSE IF ( .NOT. TRA) THEN !......NOT SYM - - IF ( .NOT. UNI) THEN -C -C .......General Not Unit, No Traspose -C - if (beta == szero) then - if (alpha==sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = alpha*acc - enddo - - endif - - else if (beta==sone) then - - if (alpha==sone) then - do i = 1, m - acc = y(i) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = y(i) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = alpha*acc + y(i) - enddo - endif - - else if (beta==-sone) then - - if (alpha==sone) then - do i = 1, m - acc = -y(i) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = -y(i) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j)) - enddo - y(i) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = alpha*acc - y(i) - enddo - endif - else - if (alpha==sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = acc + beta*y(i) - enddo - else if (alpha==-sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j)) - enddo - y(i) = acc + beta*y(i) - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j)) - enddo - y(i) = alpha*acc + beta*y(i) - enddo - endif - end if -C - ELSE IF (UNI) THEN -C - IF (BETA.NE.SZERO) THEN - DO 280 I = 1, M - ACC = SZERO - DO 260 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 260 CONTINUE - Y(I) = ALPHA*(ACC+X(I)) + BETA*Y(I) - 280 CONTINUE - ELSE !(BETA.EQ.SZERO) - DO I = 1, M - ACC = SZERO - DO J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - ENDDO - Y(I) = ALPHA*(ACC+X(I)) - ENDDO - ENDIF - END IF !....End Testing on UNI -C - ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.SZERO) THEN - DO 300 I = 1, M - Y(I) = BETA*Y(I) - 300 CONTINUE - ELSE !(BETA.EQ.SZERO) - DO I = 1, M - Y(I) = SZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.SZERO) THEN - DO 320 I = 1, M - Y(I) = BETA*Y(I) + ALPHA*X(I) - 320 CONTINUE - ELSE !(BETA.EQ.SZERO) - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C - END IF !....UNI -C - IF (ALPHA.EQ.SONE) THEN -C - DO 360 I = 1, N - DO 340 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + AS(J)*X(I) - 340 CONTINUE - 360 CONTINUE -C - ELSE IF (ALPHA.EQ.-SONE) THEN -C - DO 400 I = 1, n - DO 380 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) - AS(J)*X(I) - 380 CONTINUE - 400 CONTINUE -C - ELSE !.....Else on TRA -C -C This work array is used for efficiency -C - IF (LWORK.LT.N) THEN - IERROR = 60 - WORK(1) = DBLE(N) - RETURN - ENDIF - DO 420 I = 1, N - WORK(I) = ALPHA*X(I) - 420 CONTINUE -C - DO 460 I = 1, n - DO 440 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + AS(J)*WORK(I) - 440 CONTINUE - 460 CONTINUE -C - END IF !.....End testing on ALPHA - - END IF !.....End testing on SYM -C - RETURN -C -C END OF DSRMV -C - END - diff --git a/base/serial/csr/scsrmv2.f b/base/serial/csr/scsrmv2.f deleted file mode 100644 index 6f17508b9..000000000 --- a/base/serial/csr/scsrmv2.f +++ /dev/null @@ -1,530 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* DSRMV modified for SPARKER -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* DSMMV * -* * -* ENTRY-POINT = DSRMV * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'L' 'U' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE SCSRMV2(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, - + BETA,Y,LDY, WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - integer nb - parameter (nb=2) -C .. Scalar Arguments .. - real(psb_spk_) ALPHA, BETA - INTEGER M, N,LWORK,IERROR,ldx,ldy - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - real(psb_dpk_) ACC(nb) - INTEGER I, J, K, NCOLA, NROWA - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR = 0 - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) -C - if ( .not. tra) then - nrowa = m - ncola = n - else if (tra) then - nrowa = n - ncola = m - end if !(....tra) - - if (alpha.eq.szero) then - if (beta.eq.szero) then - do i = 1, m - y(i,1:nb) = szero - enddo - else - do 20 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 20 continue - endif - return - end if - -c - if (sym) then - if (uni) then -c -c ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - if (beta.ne.szero) then - do i = 1, m -C -C Product for diagonal elements -c - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - enddo - else - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -C Product for other elements - do 80 i = 1, m - acc = szero - do 60 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 60 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 80 continue -C - else if ( .not. uni) then -C -C Check if matrix is lower or upper -C - if (psb_toupper(trans).eq.'L') then -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - if (beta.ne.szero) then - do 100 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 100 continue - else - do i = 1, m - y(i,1:nb) = szero - enddo - endif - - do 140 i = 1, m - acc = szero - do 120 j = ia(i), ia(i+1) - 1 ! it was -2 - K = ja(j) -C -C To be optimized -C - if (k.ne.i) then !for symmetric element - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 120 continue - - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 140 continue - else ! ....Trans<>L -C -C UPPER CASE -C ....OK!! -C - if (beta.ne.szero) then - do 160 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 160 continue - else - do i = 1, m - y(i,1:nb) = szero - enddo - endif - - do 200 i = 1, m - acc = szero - do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 - k = ja(j) -C -C To be optimized -C - if (k.ne.i) then - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 180 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 200 continue - end if ! ......TRANS=='L' - end if ! ......Not UNI -c - else if ( .not. tra) then !......NOT SYM - - if ( .not. uni) then -C -C .......General Not Unit, No Traspose -C - - if (beta == szero) then - if (alpha==sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - enddo - - endif - - else if (beta==sone) then - - if (alpha==sone) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + y(i,1:nb) - enddo - endif - - else if (beta==-sone) then - - if (alpha==sone) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - y(i,1:nb) - enddo - endif - else - if (alpha==sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else if (alpha==-sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + beta*y(i,1:nb) - enddo - endif - end if -c - else if (uni) then -c - if (beta.ne.szero) then - do 280 i = 1, m - acc(1:nb) = szero - do 260 j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - 260 continue - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) - 280 continue - else !(beta.eq.szero) - do i = 1, m - acc(1:nb) = szero - do j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) - enddo - endif - end if !....End Testing on UNI -C - else if (tra) then !....Else on SYM (swapped M and N) -C - if ( .not. uni) then -c - if (beta.ne.szero) then - do 300 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 300 continue - else !(BETA.EQ.SZERO) - do i = 1, m - y(i,1:nb) = szero - enddo - endif -c - else if (uni) then -c - - if (beta.ne.szero) then - do 320 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - 320 continue - else !(BETA.EQ.SZERO) - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -c - end if !....UNI -C - if (alpha.eq.sone) then -c - do 360 i = 1, n - do 340 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) - 340 continue - 360 continue -c - else if (alpha.eq.-sone) then -c - do 400 i = 1, n - do 380 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) - 380 continue - 400 continue -c - else !.....Else on TRA -C -C This work array is used for efficiency -C - if (lwork.lt.n) then - ierror = 60 - work(1) = dble(n) - return - endif -c$$$ do 420 i = 1, n -c$$$ work(i) = alpha*x(i,1:4) -c$$$ 420 continue -c$$$C -c$$$ DO 460 I = 1, n -c$$$ DO 440 J = IA(I), IA(I+1) - 1 -c$$$ K = JA(J) -c$$$ Y(K) = Y(K) + AS(J)*WORK(I) -c$$$ 440 CONTINUE -c$$$ 460 CONTINUE -c - end if !.....end testing on alpha - - end if !.....end testing on sym -c - return -c -c end of dsrmv -c - end - diff --git a/base/serial/csr/scsrmv3.f b/base/serial/csr/scsrmv3.f deleted file mode 100644 index 7d2c1f725..000000000 --- a/base/serial/csr/scsrmv3.f +++ /dev/null @@ -1,530 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* DSRMV modified for SPARKER -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* DSMMV * -* * -* ENTRY-POINT = DSRMV * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'L' 'U' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE SCSRMV3(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, - + BETA,Y,LDY, WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - integer nb - parameter (nb=3) -C .. Scalar Arguments .. - real(psb_spk_) ALPHA, BETA - INTEGER M, N,LWORK,IERROR,ldx,ldy - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - real(psb_dpk_) ACC(nb) - INTEGER I, J, K, NCOLA, NROWA - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR = 0 - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) -C - if ( .not. tra) then - nrowa = m - ncola = n - else if (tra) then - nrowa = n - ncola = m - end if !(....tra) - - if (alpha.eq.szero) then - if (beta.eq.szero) then - do i = 1, m - y(i,1:nb) = szero - enddo - else - do 20 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 20 continue - endif - return - end if - -c - if (sym) then - if (uni) then -c -c ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - if (beta.ne.szero) then - do i = 1, m -C -C Product for diagonal elements -c - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - enddo - else - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -C Product for other elements - do 80 i = 1, m - acc = szero - do 60 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 60 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 80 continue -C - else if ( .not. uni) then -C -C Check if matrix is lower or upper -C - if (psb_toupper(trans).eq.'L') then -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - if (beta.ne.szero) then - do 100 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 100 continue - else - do i = 1, m - y(i,1:nb) = szero - enddo - endif - - do 140 i = 1, m - acc = szero - do 120 j = ia(i), ia(i+1) - 1 ! it was -2 - K = ja(j) -C -C To be optimized -C - if (k.ne.i) then !for symmetric element - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 120 continue - - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 140 continue - else ! ....Trans<>L -C -C UPPER CASE -C ....OK!! -C - if (beta.ne.szero) then - do 160 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 160 continue - else - do i = 1, m - y(i,1:nb) = szero - enddo - endif - - do 200 i = 1, m - acc = szero - do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 - k = ja(j) -C -C To be optimized -C - if (k.ne.i) then - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 180 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 200 continue - end if ! ......TRANS=='L' - end if ! ......Not UNI -c - else if ( .not. tra) then !......NOT SYM - - if ( .not. uni) then -C -C .......General Not Unit, No Traspose -C - - if (beta == szero) then - if (alpha==sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - enddo - - endif - - else if (beta==sone) then - - if (alpha==sone) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + y(i,1:nb) - enddo - endif - - else if (beta==-sone) then - - if (alpha==sone) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - y(i,1:nb) - enddo - endif - else - if (alpha==sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else if (alpha==-sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + beta*y(i,1:nb) - enddo - endif - end if -c - else if (uni) then -c - if (beta.ne.szero) then - do 280 i = 1, m - acc(1:nb) = szero - do 260 j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - 260 continue - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) - 280 continue - else !(beta.eq.szero) - do i = 1, m - acc(1:nb) = szero - do j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) - enddo - endif - end if !....End Testing on UNI -C - else if (tra) then !....Else on SYM (swapped M and N) -C - if ( .not. uni) then -c - if (beta.ne.szero) then - do 300 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 300 continue - else !(BETA.EQ.SZERO) - do i = 1, m - y(i,1:nb) = szero - enddo - endif -c - else if (uni) then -c - - if (beta.ne.szero) then - do 320 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - 320 continue - else !(BETA.EQ.SZERO) - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -c - end if !....UNI -C - if (alpha.eq.sone) then -c - do 360 i = 1, n - do 340 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) - 340 continue - 360 continue -c - else if (alpha.eq.-sone) then -c - do 400 i = 1, n - do 380 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) - 380 continue - 400 continue -c - else !.....Else on TRA -C -C This work array is used for efficiency -C - if (lwork.lt.n) then - ierror = 60 - work(1) = dble(n) - return - endif -c$$$ do 420 i = 1, n -c$$$ work(i) = alpha*x(i,1:4) -c$$$ 420 continue -c$$$C -c$$$ DO 460 I = 1, n -c$$$ DO 440 J = IA(I), IA(I+1) - 1 -c$$$ K = JA(J) -c$$$ Y(K) = Y(K) + AS(J)*WORK(I) -c$$$ 440 CONTINUE -c$$$ 460 CONTINUE -c - end if !.....end testing on alpha - - end if !.....end testing on sym -c - return -c -c end of dsrmv -c - end - diff --git a/base/serial/csr/scsrmv4.f b/base/serial/csr/scsrmv4.f deleted file mode 100644 index 0952832ba..000000000 --- a/base/serial/csr/scsrmv4.f +++ /dev/null @@ -1,530 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* DSRMV modified for SPARKER -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* DSMMV * -* * -* ENTRY-POINT = DSRMV * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'L' 'U' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: REAL*8: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: REAL*8 ARRAY(N) (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: REAL*8. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: REAL*8 ARRAY(M) (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** - SUBROUTINE SCSRMV4(TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,LDX, - + BETA,Y,LDY, WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - integer nb - parameter (nb=4) -C .. Scalar Arguments .. - real(psb_spk_) ALPHA, BETA - INTEGER M, N,LWORK,IERROR,ldx,ldy - CHARACTER DIAG, TRANS -C .. Array Arguments .. - real(psb_dpk_) AS(*), WORK(*), X(LDX,NB), Y(LDY,NB) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - real(psb_dpk_) ACC(nb) - INTEGER I, J, K, NCOLA, NROWA - LOGICAL SYM, TRA, UNI -C .. Executable Statements .. -C - IERROR = 0 - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - -C Symmetric matrix upper or lower - SYM = ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) -C - if ( .not. tra) then - nrowa = m - ncola = n - else if (tra) then - nrowa = n - ncola = m - end if !(....tra) - - if (alpha.eq.szero) then - if (beta.eq.szero) then - do i = 1, m - y(i,1:nb) = szero - enddo - else - do 20 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 20 continue - endif - return - end if - -c - if (sym) then - if (uni) then -c -c ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - if (beta.ne.szero) then - do i = 1, m -C -C Product for diagonal elements -c - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - enddo - else - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -C Product for other elements - do 80 i = 1, m - acc = szero - do 60 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 60 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 80 continue -C - else if ( .not. uni) then -C -C Check if matrix is lower or upper -C - if (psb_toupper(trans).eq.'L') then -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - if (beta.ne.szero) then - do 100 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 100 continue - else - do i = 1, m - y(i,1:nb) = szero - enddo - endif - - do 140 i = 1, m - acc = szero - do 120 j = ia(i), ia(i+1) - 1 ! it was -2 - K = ja(j) -C -C To be optimized -C - if (k.ne.i) then !for symmetric element - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 120 continue - - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 140 continue - else ! ....Trans<>L -C -C UPPER CASE -C ....OK!! -C - if (beta.ne.szero) then - do 160 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 160 continue - else - do i = 1, m - y(i,1:nb) = szero - enddo - endif - - do 200 i = 1, m - acc = szero - do 180 j = ia(i) , ia(i+1) - 1 ! removed +1 - k = ja(j) -C -C To be optimized -C - if (k.ne.i) then - y(k,1:nb) = y(k,1:nb) + alpha*as(j)*x(i,1:nb) - endif - acc(1:nb) = acc(1:nb) + as(j)*x(k,1:nb) - 180 continue - y(i,1:nb) = y(i,1:nb) + alpha*acc(1:nb) - 200 continue - end if ! ......TRANS=='L' - end if ! ......Not UNI -c - else if ( .not. tra) then !......NOT SYM - - if ( .not. uni) then -C -C .......General Not Unit, No Traspose -C - - if (beta == szero) then - if (alpha==sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - enddo - - endif - - else if (beta==sone) then - - if (alpha==sone) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + y(i,1:nb) - enddo - endif - - else if (beta==-sone) then - - if (alpha==sone) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else if (alpha==-sone) then - do i = 1, m - acc = -y(i,1:nb) - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc - y(i,1:nb) - enddo - endif - else - if (alpha==sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else if (alpha==-sone) then - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc - as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = acc + beta*y(i,1:nb) - enddo - else - do i = 1, m - acc = szero - do j = ia(i), ia(i+1) - 1 - acc = acc + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*acc + beta*y(i,1:nb) - enddo - endif - end if -c - else if (uni) then -c - if (beta.ne.szero) then - do 280 i = 1, m - acc(1:nb) = szero - do 260 j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - 260 continue - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) + beta*y(i,1:nb) - 280 continue - else !(beta.eq.szero) - do i = 1, m - acc(1:nb) = szero - do j = ia(i), ia(i+1) - 1 - acc(1:nb) = acc(1:nb) + as(j)*x(ja(j),1:nb) - enddo - y(i,1:nb) = alpha*(acc(1:nb)+x(i,1:nb)) - enddo - endif - end if !....End Testing on UNI -C - else if (tra) then !....Else on SYM (swapped M and N) -C - if ( .not. uni) then -c - if (beta.ne.szero) then - do 300 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) - 300 continue - else !(BETA.EQ.SZERO) - do i = 1, m - y(i,1:nb) = szero - enddo - endif -c - else if (uni) then -c - - if (beta.ne.szero) then - do 320 i = 1, m - y(i,1:nb) = beta*y(i,1:nb) + alpha*x(i,1:nb) - 320 continue - else !(BETA.EQ.SZERO) - do i = 1, m - y(i,1:nb) = alpha*x(i,1:nb) - enddo - endif - -c - end if !....UNI -C - if (alpha.eq.sone) then -c - do 360 i = 1, n - do 340 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) + as(j)*x(i,1:nb) - 340 continue - 360 continue -c - else if (alpha.eq.-sone) then -c - do 400 i = 1, n - do 380 j = ia(i), ia(i+1) - 1 - k = ja(j) - y(k,1:nb) = y(k,1:nb) - as(j)*x(i,1:nb) - 380 continue - 400 continue -c - else !.....Else on TRA -C -C This work array is used for efficiency -C - if (lwork.lt.n) then - ierror = 60 - work(1) = dble(n) - return - endif -c$$$ do 420 i = 1, n -c$$$ work(i) = alpha*x(i,1:4) -c$$$ 420 continue -c$$$C -c$$$ DO 460 I = 1, n -c$$$ DO 440 J = IA(I), IA(I+1) - 1 -c$$$ K = JA(J) -c$$$ Y(K) = Y(K) + AS(J)*WORK(I) -c$$$ 440 CONTINUE -c$$$ 460 CONTINUE -c - end if !.....end testing on alpha - - end if !.....end testing on sym -c - return -c -c end of dsrmv -c - end - diff --git a/base/serial/csr/scsrsm.f b/base/serial/csr/scsrsm.f deleted file mode 100644 index b29a08631..000000000 --- a/base/serial/csr/scsrsm.f +++ /dev/null @@ -1,123 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, - * B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - real(psb_spk_) ALPHA, BETA - INTEGER LDB, LDC, LWORK, M, N, IERROR - CHARACTER UNITD, TRANST - real(psb_spk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 - INTEGER I, K - CHARACTER DIAG, UPLO -C .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5), err_Act - - NAME = 'DCSRSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - int_Val(1)=0 - UPLO = '?' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' - IF (UPLO.EQ.'?') THEN - int_val(1) = 7 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' - IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' - IF(UNITD.EQ.'B') THEN - IERROR=5 - int_val(1) = 4 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF (psb_toupper(UNITD).EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE - END IF - if ((alpha.ne.1.d0) .or.(beta .ne.0.0d0)) then - if (lwork .lt. m) then - int_val(1) = 17 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - DO I = 1, N - CALL SCSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),work) - do k=1,m - c(k,i) = beta*c(k,i) + alpha*work(k) - enddo - enddo - - else - DO 60 I = 1, N - CALL SCSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),C(1,I)) - 60 CONTINUE - endif - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/csr/scsrsv.f b/base/serial/csr/scsrsv.f deleted file mode 100644 index 3c0871d62..000000000 --- a/base/serial/csr/scsrsv.f +++ /dev/null @@ -1,133 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SCSRSV(UPLO,TRANS,DIAG,N,AS,JA,IA,B,X,IERROR) - use psb_const_mod - use psb_string_mod - real(psb_spk_) ZERO - PARAMETER (ZERO=0.0E0) - INTEGER N, IERROR - CHARACTER DIAG, TRANS, UPLO - real(psb_spk_) AS(*), B(*), X(*) - INTEGER IA(*), JA(*) - real(psb_spk_) ACC - INTEGER I, J, K - LOGICAL LOW, TRA, UNI - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - LOW = (psb_toupper(UPLO).EQ.'L') - IF ( .NOT. TRA) THEN - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 40 I = 1, N - ACC = ZERO - DO 20 J = IA(I), IA(I+1) - 2 - ACC = ACC + AS(J)*X(JA(J)) - 20 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I+1)-1) - 40 CONTINUE - ELSE IF (UNI) THEN - DO 80 I = 1, N - ACC = ZERO - DO 60 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 60 CONTINUE - X(I) = B(I) - ACC - 80 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 120 I = N, 1, -1 - ACC = ZERO - DO 100 J = IA(I) + 1, IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 100 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I)) - 120 CONTINUE - ELSE IF (UNI) THEN - DO 160 I = N, 1, -1 - ACC = ZERO - DO 140 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 140 CONTINUE - X(I) = B(I) - ACC - 160 CONTINUE - END IF - END IF - ELSE IF (TRA) THEN - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF ( .NOT. UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF ( .NOT. LOW) THEN - IF ( .NOT. UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF - END IF - RETURN - END - - - diff --git a/base/serial/csr/zcrnrmi.f b/base/serial/csr/zcrnrmi.f deleted file mode 100644 index 02f92a91f..000000000 --- a/base/serial/csr/zcrnrmi.f +++ /dev/null @@ -1,65 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C - FUNCTION ZCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,IERROR) - use psb_const_mod - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) zcrnrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - complex(psb_dpk_) A(*) -C .. Local scalars .. - INTEGER I, J - real(psb_dpk_) NRMI, SUM - - NRMI = 0.D0 - DO I = 1, M - SUM = 0.D0 - DO J = IA2(I), IA2(I+1)-1 -C -C .. definition coerent abs -C -C SUM = SUM + ABS(A(J)) -C -C .. essl_way abs -C - SUM = SUM + ABS(DBLE(A(J))) + ABS(AIMAG(A(J))) - ENDDO - NRMI = MAX(NRMI, SUM) - ENDDO - - ZCRNRMI = NRMI - END diff --git a/base/serial/csr/zcsrck.f b/base/serial/csr/zcsrck.f deleted file mode 100644 index 77961784c..000000000 --- a/base/serial/csr/zcsrck.f +++ /dev/null @@ -1,166 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Purpose -C ======= -C -C Performing checks on sparse matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will use -C matrix P or the transpose of P for the permutation as follows: -C TRANS = 'N' -> permute with matrix P -C TRANS = 'T' or 'C' -> permute the transpose of P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C DESCRA - CHARACTER*5 array of DIMENSION (10) -C On entry DESCRA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPRP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit specify the error code. -C IERROR = 0 no errors -C IERROR > 0 error in integrity check - SUBROUTINE ZCSRCK(TRANS,M,N,DESCRA,A,IA1,IA2, - + WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LWORK,M, N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - complex(psb_dpk_) A(*), WORK(*) - INTEGER IA1(*), IA2(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J, nrow, nind -C -C .. Executable Statements .. -C - -C -C Check #1: Character descriptor have valid values -C - IERROR = 0 - - IF ((psb_toupper(DESCRA(1:1)).NE.'G').AND. - + (psb_toupper(DESCRA(1:1)).NE.'S').AND. - + (psb_toupper(DESCRA(1:1)).NE.'H').AND. - + (psb_toupper(DESCRA(1:1)).NE.'T').AND. - + (psb_toupper(DESCRA(1:1)).NE.'A').AND. - + (psb_toupper(DESCRA(1:1)).NE.'D')) THEN - IERROR = 11 - GOTO 9999 - END IF - IF ((psb_toupper(DESCRA(2:2)).NE.'U').AND. - + (psb_toupper(DESCRA(2:2)).NE.'L')) THEN - IERROR = 12 - GOTO 9999 - END IF - IF ((psb_toupper(DESCRA(3:3)).NE.'U').AND. - + (psb_toupper(DESCRA(3:3)).NE.'N')) THEN - IERROR = 13 - GOTO 9999 - END IF -C -C Check #2: Pointers have non decreasing order -C - IF (IA2(1).LE.0) THEN - IERROR = 14 - GOTO 9999 - ENDIF - - NROW = 0 - DO 10 I = 1, M - IF (IA2(I) .GT. IA2(I+1)) THEN - NROW = NROW + 1 - END IF - 10 CONTINUE - IF (NROW .GT. 0) THEN - IERROR = 15 - GOTO 9999 - END IF -C -C Check #3: Indices are within problem dimension -C - NIND = 0 - DO 20 I = 1, M - DO 30 J = IA2(I), IA2(I+1) - 1 - IF ((IA1(J).LT.0) .OR. (IA1(J).GT.N)) THEN - NIND = NIND + 1 - END IF - 30 CONTINUE - 20 CONTINUE - IF (NIND .GT. 0) THEN - IERROR = 16 - GOTO 9999 - END IF - 9999 CONTINUE - RETURN - END diff --git a/base/serial/csr/zcsrmm.f b/base/serial/csr/zcsrmm.f deleted file mode 100644 index c9f9d9dc9..000000000 --- a/base/serial/csr/zcsrmm.f +++ /dev/null @@ -1,237 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE ZCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, -C * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) -C -C Purpose -C ======= -C -C Computing C <-- ALPHA A B + BETA C or -C C <-- ALPHA At B + BETA C or -C C <-- ALPHA Atc B + BETA C -C Called by ZSWMM -C This routine calls kernel for CSR data structure. -C -C Parameters -C ========== -C -C TRANSA - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' -> use A' (transpose of matrix A) -C TRANS = 'C' -> use conjugate transpose of A -C Unchanged on exit. -C -C N.B.: M, K for C matrix -C M, N for A matrix -C N, K for B matrix -C In the calling subroutine, ZSWMM, it was: -C M, N for C matrix -C M, K for A matrix -C K, N for B matrix -C Check the parameters order! -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C AR - COMPLEX*16 array of DIMENSION (*) -C On entry AR specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C JA - INTEGER array of dimension (*) -C On entry JA holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA - INTEGER array of dimension (*) -C On entry IA holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - COMPLEX*16 matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying ZSWMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C - SUBROUTINE ZCSRMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * JA,IA,B,LDB,BETA,C,LDC,WORK,LWORK) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - complex(psb_dpk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N, LWORK - CHARACTER TRANSA -C .. Array Arguments .. - complex(psb_dpk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J - CHARACTER DIAG, TRANS - -C .. External Subroutines .. - EXTERNAL ZSRMV -C .. Executable Statements .. -C -C -C IF (DESCRA(1).EQ.'G') TRANS = TRANSA -C -C .. Why to loose TRANSA for H, T, A matrices? -C - TRANS = TRANSA -C - IF ((psb_toupper(DESCRA(1:1)).EQ.'S').AND. - + (psb_toupper(DESCRA(2:2)).EQ.'U')) THEN - IF (psb_toupper(TRANSA).EQ.'C') THEN - TRANS = 'V' - ELSE - TRANS = 'U' - ENDIF - ENDIF - IF ((psb_toupper(DESCRA(1:1)).EQ.'S').AND. - + (psb_toupper(DESCRA(2:2)).EQ.'L')) THEN - IF (psb_toupper(TRANSA).EQ.'C') THEN - TRANS = 'M' - ELSE - TRANS = 'L' - ENDIF - ENDIF - -C .. Diagonal matrix - IF (psb_toupper(DESCRA(1:1)).EQ.'D') THEN -C .. Diagonal matrix with unitary values - IF (psb_toupper(DESCRA(3:3)).EQ.'U') THEN - DO 40 I = 1, K - DO 20 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) - 20 CONTINUE - 40 CONTINUE - RETURN -C .. Diagonal matrix to be conjugated - ELSE IF (psb_toupper(TRANSA).EQ.'C') THEN - DO 80 I = 1, K - DO 60 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA * - + CONJG(AR(J)) * B(J,I) - 60 CONTINUE - 80 CONTINUE - RETURN -C .. Generic diagonal matrix - ELSE - DO 91 I = 1, K - DO 90 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA * - + AR(J) * B(J,I) - 90 CONTINUE - 91 CONTINUE - RETURN - ENDIF - END IF -C - IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' - IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' -C -C C = A*B or C=A'*B or C=conjug(A')*B -C -C TRANS = -C 'N': Compute using A as it is. -C 'T': Compute using the transpose of A. -C 'C': Compute using conjugate transpose of A. -C 'U': A is symmetric, stored upper, compute as it is; -C (transposition makes no sense) -C 'V': A is symmetric, stored upper, to be conjugated. -C 'L': A is symmetric, stored lower, compute as it is. -C 'M': A is symmetric, stored lower, to be conjugated. -C DIAG = -C 'U': Unitary diagonal. -C 'N': Generic diagonal. - -C - DO 100 I = 1, K - CALL ZSRMV(TRANS,DIAG,M,N,ALPHA,AR,JA,IA,B(1,I), - + BETA,C(1,I),WORK) - 100 CONTINUE - RETURN - END - diff --git a/base/serial/csr/zcsrrws.f b/base/serial/csr/zcsrrws.f deleted file mode 100644 index 902988f4d..000000000 --- a/base/serial/csr/zcsrrws.f +++ /dev/null @@ -1,70 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C - SUBROUTINE ZCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11 - complex(psb_dpk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER I, J - real(psb_dpk_) SUM - - IF (psb_toupper(TRANS).EQ.'N') THEN - DO I = 1, M - ROWSUM(I) = (0.0D0, 0.0D0) - DO J = IA2(I), IA2(I + 1) - 1 - ROWSUM(I) = ROWSUM(I) + - + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - ENDDO - ELSE IF ((psb_toupper(TRANS).EQ.'T').OR. - + (psb_toupper(TRANS).EQ.'C')) THEN - DO J = 1, N - ROWSUM(J) = (0.0D0, 0.0D0) - ENDDO - DO I = 1, M - DO J = IA2(I), IA2(I + 1) - 1 - ROWSUM(IA1(J)) = ROWSUM(IA1(J)) + - + ABS(REAL(A(J))) + ABS(AIMAG(A(J))) - ENDDO - ENDDO - ENDIF - END - - - diff --git a/base/serial/csr/zcsrsm.f b/base/serial/csr/zcsrsm.f deleted file mode 100644 index 72a663a33..000000000 --- a/base/serial/csr/zcsrsm.f +++ /dev/null @@ -1,118 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE ZCSRSM(TRANST,M,N,UNITD,D,ALPHA,DESCRA,A,JA,IA, - * B,LDB,BETA,C,LDC,WORK,LWORK) - use psb_const_mod - use psb_string_mod - complex(psb_dpk_) ALPHA, BETA - INTEGER LDB, LDC, LWORK, M, N - CHARACTER UNITD, TRANST - complex(psb_dpk_) A(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 - INTEGER I, K - CHARACTER DIAG, UPLO - -C .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5),err_act - - NAME = 'ZCSRSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - int_Val(1)=0 - UPLO = '?' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' - IF (UPLO.EQ.'?') THEN - int_val(1) = 7 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (psb_toupper(DESCRA(3:3)).EQ.'N') DIAG = 'N' - IF (psb_toupper(DESCRA(3:3)).EQ.'U') DIAG = 'U' - IF(psb_toupper(UNITD).EQ.'B') THEN - IERROR=5 - int_val(1) = 4 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF (psb_toupper(UNITD).EQ.'R') THEN - DO 40 I = 1, N - DO 20 K = 1, M - B(K,I) = B(K,I)*D(K) - 20 CONTINUE - 40 CONTINUE - END IF - - if ((alpha.ne.(1.d0,0.d0)) .or.(beta .ne.(0.0d0,0.d0))) then - if (lwork .lt. m) then - int_val(1) = 17 - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - DO I = 1, N - CALL ZSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),work) - do k=1,m - c(k,i) = beta*c(k,i) + alpha*work(k) - enddo - enddo - else - DO I = 1, N - CALL ZSRSV(UPLO,TRANST,DIAG,M,A,JA,IA,B(1,I),c(1,i)) - enddo - endif - IF (UNITD.EQ.'L') THEN - DO 45 I = 1, N - DO 25 K = 1, M - C(K,I) = C(K,I)*D(K) - 25 CONTINUE - 45 CONTINUE - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/csr/zsrmv.f b/base/serial/csr/zsrmv.f deleted file mode 100644 index 87a0eb23b..000000000 --- a/base/serial/csr/zsrmv.f +++ /dev/null @@ -1,562 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -*********************************************************************** -* ZSRMV modified for SPARKER * -* * -* FUNCTION: Driver for routines performing one of the sparse * -* matrix vector operations * -* * -* y = alpha*op(A)*x + beta*y * -* * -* where op(A) is one of: * -* * -* op(A) = A or op(A) = A' or * -* op(A) = conjug(A') or * -* op(A) = lower or upper part of A * -* * -* alpha and beta are scalars. * -* The data structure of the matrix is related * -* to the scalar computer. * -* This is an internal routine called by: * -* ZCSRMM * -* * -* ENTRY-POINT = ZSRMV * -* * -* * -* INPUT = * -* * -* * -* SYMBOLIC NAME: TRANS * -* POSITION: PARAMETER NO 1. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'T' 'C' 'L' 'M' 'U' 'V' * -* DESCRIPTION: Specifies the form of op(A) to be used in the * -* matrix vector multiplications as follows: * -* * -* TRANS = 'N' , op( A ) = A. * -* * -* TRANS = 'T' , op( A ) = A'. * -* * -* TRANS = 'C' , OP( A ) = conjug(A') * -* * -* TRANS = 'L' or 'U', op( A ) = lower or * -* upper part of A * -* * -* TRANS = 'M' or 'V', op( A ) = lower or * -* upper part of conjugate of A * -* * -* SYMBOLIC NAME: DIAG * -* POSITION: PARAMETER NO 2. * -* ATTRIBUTES: CHARACTER*1 * -* VALUES: 'N' 'U' * -* DESCRIPTION: * -* Specifies whether or not the matrix A has * -* unit diagonal as follows: * -* * -* DIAG = 'N' A is not assumed * -* to have unit diagonal * -* * -* DIAG = 'U' A is assumed * -* to have unit diagonal. * -* * -* WARNING: it is the caller's responsibility * -* to ensure that if the matrix has unit * -* diagonal, there are no elements of the * -* diagonal are stored in the arrays AS and JA. * -* * -* SYMBOLIC NAME: M * -* POSITION: PARAMETER NO 3. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: M >= 0 * -* DESCRIPTION: Number of rows of the matrix op(A). * -* * -* SYMBOLIC NAME: N * -* POSITION: PARAMETER NO 4. * -* ATTRIBUTES: INTEGER*4. * -* VALUES: N >= 0 * -* DESCRIPTION: Number of columns of the matrix op(A) * -* * -* SYMBOLIC NAME: ALPHA * -* POSITION: PARAMETER NO 5. * -* ATTRIBUTES: COMPLEX*16. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar alpha. * -* * -* * -* SYMBOLIC NAME: AS * -* POSITION: PARAMETER NO 6. * -* ATTRIBUTES: COMPLEX*16: ARRAY(IA(M+1)-1) * -* VALUES: ANY * -* DESCRIPTION: Array containing the non zero coefficients of * -* the sparse matrix op(A). * -* * -* SYMBOLIC NAME: JA * -* POSITION: PARAMETER NO 7. * -* ATTRIBUTES: INTEGER*4: ARRAY(IA(M+1)-1) * -* VALUES: 0 < JA(I) <= M * -* DESCRIPTION: Array containing the column number of the * -* nonzero coefficients stored in array AS. * -* * -* SYMBOLIC NAME: IA * -* POSITION: PARAMETER NO 8. * -* ATTRIBUTES: INTEGER*4: ARRAY(*) * -* VALUES: IA(I) > 0 * -* DESCRIPTION: Contains the pointers for the beginning of * -* each rows. * -* * -* * -* SYMBOLIC NAME: X * -* POSITION: PARAMETER NO 9. * -* ATTRIBUTES: COMPLEX*16 ARRAY(N) * -* (or ARRAY(M) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* multiplied by the matrix A. * -* * -* SYMBOLIC NAME: BETA * -* POSITION: PARAMETER NO 10. * -* ATTRIBUTES: COMPLEX*16. * -* VALUES: any. * -* DESCRIPTION: Specifies the scalar beta. * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: COMPLEX*16 ARRAY(M) * -* (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector to be * -* updated by the matrix-vector multiplication. * -* * -* SYMBOLIC NAME: WORK * -* POSITION: PARAMETER NO 12. * -* ATTRIBUTES: COMPLEX*16 ARRAY(M) * -* (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Work area available to the program. It is used * -* only when TRANS = 'T'. * -* * -* OUTPUT = * -* * -* * -* SYMBOLIC NAME: Y * -* POSITION: PARAMETER NO 11. * -* ATTRIBUTES: COMPLEX*16 ARRAY(M) * -* (or ARRAY(N) when op(A) = A') * -* VALUES: any. * -* DESCRIPTION: Contains the values of the vector * -* updated by the matrix-vector multiplication. * -* * -* * -*********************************************************************** -C - SUBROUTINE ZSRMV (TRANS,DIAG,M,N,ALPHA,AS,JA,IA,X,BETA,Y,WORK) - use psb_const_mod - use psb_string_mod -C .. Parameters .. - complex(psb_dpk_) ONE, ZERO - PARAMETER (ONE=(1.0D0, 0.0D0), ZERO=(0.0D0, 0.0D0)) -C .. Scalar Arguments .. - complex(psb_dpk_) ALPHA, BETA - INTEGER M, N - CHARACTER DIAG, TRANS -C .. Array Arguments .. - complex(psb_dpk_) AS(*), WORK(*), X(*), Y(*) - INTEGER IA(*), JA(*) -C .. Local Scalars .. - complex(psb_dpk_) ACC - INTEGER I, J, K, NCOLA, NROWA,DUM - LOGICAL SYM, TRA, COTRA, UNI -C .. Executable Statements .. -C - UNI = psb_toupper(DIAG).EQ.'U' -C -C .. Not simmetric matrix - TRA = psb_toupper(TRANS).EQ.'T' - COTRA = psb_toupper(TRANS).EQ.'C' - -C .. Symmetric matrix upper or lower - SYM = (psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U').OR. - + (psb_toupper(TRANS).EQ.'M').OR. - + (psb_toupper(TRANS).EQ.'V') -C - IF (.NOT.(TRA.OR.COTRA)) THEN - NROWA = M - NCOLA = N - ELSE - NROWA = N - NCOLA = M - END IF !(....(CO)TRA) - - IF (ALPHA.EQ.ZERO) THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, M - Y(I) = ZERO - ENDDO - ELSE - DO 20 I = 1, M - Y(I) = BETA*Y(I) - 20 CONTINUE - ENDIF - RETURN - END IF - -C - IF (SYM) THEN - IF (UNI) THEN -C -C ......Symmetric with unitary diagonal....... -C ....OK!! -C To be optimized - - IF (BETA.NE.ZERO) THEN - DO 40 I = 1, M -C -C Product for diagonal elements -C - Y(I) = BETA*Y(I) + ALPHA*X(I) - 40 CONTINUE - ELSE - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C Product for other elements - IF ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'U')) THEN - DO 80 I = 1, M - ACC = ZERO - DO 60 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ACC = ACC + AS(J)*X(K) - 60 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 80 CONTINUE - ELSE ! Perform computations on conjug(A) - DO 82 I = 1, M - ACC = ZERO - DO 81 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) - ACC = ACC + CONJG(AS(J)) * X(K) - 81 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 82 CONTINUE - ENDIF -C - ELSE IF ( .NOT. UNI) THEN -C -C Check if matrix is lower or upper -C - IF ((psb_toupper(TRANS).EQ.'L').OR. - + (psb_toupper(TRANS).EQ.'M')) THEN -C -C LOWER CASE: diagonal element is the last element of row -C ....OK! - - IF (BETA.NE.ZERO) THEN - DO 100 I = 1, M - Y(I) = BETA*Y(I) - 100 CONTINUE - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - - IF (psb_toupper(TRANS).EQ.'L') THEN - DO 140 I = 1, M - ACC = ZERO - DO 120 J = IA(I), IA(I+1) - 1 ! it was -2 - K = JA(J) -C -C To be optimized -C - IF (K.NE.I) THEN !for symmetric element - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ENDIF - ACC = ACC + AS(J)*X(K) - 120 CONTINUE - - Y(I) = Y(I) + ALPHA*ACC - 140 CONTINUE - ELSE ! Perform computations on conjug(A) - DO 142 I = 1, M - ACC = ZERO - DO 141 J = IA(I), IA(I+1) - 1 ! it was -2 - K = JA(J) -C -C To be optimized -C - IF (K.NE.I) THEN !for symmetric element - Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) - ENDIF - ACC = ACC + CONJG(AS(J)) * X(K) - 141 CONTINUE - Y(I) = Y(I) + ALPHA * ACC - 142 CONTINUE - - ENDIF - - ELSE ! ....Trans<>L, M -C -C UPPER CASE -C ....OK!! -C - IF (BETA.NE.ZERO) THEN - DO 160 I = 1, M - Y(I) = BETA*Y(I) - 160 CONTINUE - ELSE - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF - IF (psb_toupper(TRANS).EQ.'U') THEN - DO 200 I = 1, M - ACC = ZERO - DO 180 J = IA(I) , IA(I+1) - 1 ! removed +1 - K = JA(J) -C -C To be optimized -C - IF(K.NE.I) THEN - Y(K) = Y(K) + ALPHA*AS(J)*X(I) - ENDIF - ACC = ACC + AS(J)*X(K) - 180 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 200 CONTINUE - ELSE ! Perform computations on conjug(A) - DO 202 I = 1, M - ACC = ZERO - DO 201 J = IA(I) , IA(I+1) - 1 ! removed +1 - K = JA(J) -C -C To be optimized -C - IF(K.NE.I) THEN - Y(K) = Y(K) + ALPHA * CONJG(AS(J)) * X(I) - ENDIF - ACC = ACC + CONJG(AS(J)) * X(K) - 201 CONTINUE - Y(I) = Y(I) + ALPHA*ACC - 202 CONTINUE - ENDIF - END IF ! ......TRANS=='L' - END IF ! ......Not UNI -C - ELSE IF ((.NOT.TRA).AND.(.NOT.COTRA)) THEN !......NOT SYM - - IF ( .NOT. UNI) THEN -C -C .......General Not Unit, No Traspose -C - - IF (BETA.NE.ZERO) THEN - DO 240 I = 1, M - ACC = ZERO - DO 220 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 220 CONTINUE - Y(I) = ALPHA*ACC + BETA*Y(I) - 240 CONTINUE - ELSE - DO I = 1, M - ACC = ZERO - DO J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - ENDDO - Y(I) = ALPHA*ACC - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO 280 I = 1, M - ACC = ZERO - DO 260 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 260 CONTINUE - Y(I) = ALPHA*(ACC+X(I)) + BETA*Y(I) - 280 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - ACC = ZERO - DO J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - ENDDO - Y(I) = ALPHA*(ACC+X(I)) - ENDDO - ENDIF - END IF !....End Testing on UNI -C - ELSE IF (TRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO 300 I = 1, M - Y(I) = BETA*Y(I) - 300 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO 320 I = 1, M - Y(I) = BETA*Y(I) + ALPHA*X(I) - 320 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C - END IF !....UNI -C - IF (ALPHA.EQ.ONE) THEN -C - DO 360 I = 1, N - DO 340 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + AS(J)*X(I) - 340 CONTINUE - 360 CONTINUE -C - ELSE IF (ALPHA.EQ.-ONE) THEN -C - DO 400 I = 1, n - DO 380 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) - AS(J)*X(I) - 380 CONTINUE - 400 CONTINUE -C - ELSE !.....Else on TRA -C -C This work array is used for efficiency -C - DO 420 I = 1, N - WORK(I) = ALPHA*X(I) - 420 CONTINUE -C - DO 460 I = 1, n - DO 440 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + AS(J)*WORK(I) - 440 CONTINUE - 460 CONTINUE -C - END IF !.....End testing on ALPHA - - ELSE IF (COTRA) THEN !....Else on SYM (swapped M and N) -C - IF ( .NOT. UNI) THEN -C - IF (BETA.NE.ZERO) THEN - DO 500 I = 1, M - Y(I) = BETA*Y(I) - 500 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - Y(I) = ZERO - ENDDO - ENDIF -C - ELSE IF (UNI) THEN -C - - IF (BETA.NE.ZERO) THEN - DO 520 I = 1, M - Y(I) = BETA*Y(I) + ALPHA*X(I) - 520 CONTINUE - ELSE !(BETA.EQ.ZERO) - DO I = 1, M - Y(I) = ALPHA*X(I) - ENDDO - ENDIF - -C - END IF !....UNI -C - IF (ALPHA.EQ.ONE) THEN -C - DO 560 I = 1, N - DO 540 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + CONJG(AS(J))*X(I) - 540 CONTINUE - 560 CONTINUE -C - ELSE IF (ALPHA.EQ.-ONE) THEN -C - DO 600 I = 1, n - DO 580 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) - CONJG(AS(J))*X(I) - 580 CONTINUE - 600 CONTINUE -C - ELSE !.....Else on TRA -C -C This work array is used for efficiency -C - DO 620 I = 1, N - WORK(I) = ALPHA*X(I) - 620 CONTINUE -C - DO 660 I = 1, n - DO 640 J = IA(I), IA(I+1) - 1 - K = JA(J) - Y(K) = Y(K) + CONJG(AS(J))*WORK(I) - 640 CONTINUE - 660 CONTINUE -C - END IF !.....End testing on ALPHA - - END IF !.....End testing on SYM -C - RETURN -C -C END OF ZSRMV -C - END - diff --git a/base/serial/csr/zsrsv.f b/base/serial/csr/zsrsv.f deleted file mode 100644 index 6458e73f4..000000000 --- a/base/serial/csr/zsrsv.f +++ /dev/null @@ -1,176 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C - SUBROUTINE ZSRSV (UPLO,TRANS,DIAG,N,AS,JA,IA,B,X) - use psb_const_mod - use psb_string_mod - complex(psb_dpk_) ZERO - PARAMETER (ZERO = (0.0D0, 0.0D0)) - INTEGER N - CHARACTER DIAG, TRANS, UPLO - complex(psb_dpk_) AS(*), B(*), X(*) - INTEGER IA(*), JA(*) - complex(psb_dpk_) ACC - INTEGER I, J, K - LOGICAL LOW, TRA, COTRA, UNI - UNI = (psb_toupper(DIAG).EQ.'U') - TRA = (psb_toupper(TRANS).EQ.'T') - COTRA = (psb_toupper(TRANS).EQ.'C') - LOW = (psb_toupper(UPLO).EQ.'L') - IF ((.NOT.TRA).AND.(.NOT.COTRA)) THEN - IF (LOW) THEN - IF (.NOT.UNI) THEN - DO 40 I = 1, N - ACC = ZERO - DO 20 J = IA(I), IA(I+1) - 2 - ACC = ACC + AS(J)*X(JA(J)) - 20 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I+1)-1) - 40 CONTINUE - ELSE IF (UNI) THEN - DO 80 I = 1, N - ACC = ZERO - DO 60 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 60 CONTINUE - X(I) = B(I) - ACC - 80 CONTINUE - END IF - ELSE IF (.NOT.LOW) THEN - IF (.NOT.UNI) THEN - DO 120 I = N, 1, -1 - ACC = ZERO - DO 100 J = IA(I) + 1, IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 100 CONTINUE - X(I) = (B(I)-ACC)/AS(IA(I)) - 120 CONTINUE - ELSE IF (UNI) THEN - DO 160 I = N, 1, -1 - ACC = ZERO - DO 140 J = IA(I), IA(I+1) - 1 - ACC = ACC + AS(J)*X(JA(J)) - 140 CONTINUE - X(I) = B(I) - ACC - 160 CONTINUE - END IF - END IF - ELSE IF (TRA) THEN - DO 180 I = 1, N - X(I) = B(I) - 180 CONTINUE - IF (LOW) THEN - IF (.NOT.UNI) THEN - DO 220 I = N, 1, -1 - X(I) = X(I)/AS(IA(I+1)-1) - ACC = X(I) - DO 200 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 200 CONTINUE - 220 CONTINUE - ELSE IF (UNI) THEN - DO 260 I = N, 1, -1 - ACC = X(I) - DO 240 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 240 CONTINUE - 260 CONTINUE - END IF - ELSE IF (.NOT.LOW) THEN - IF (.NOT.UNI) THEN - DO 300 I = 1, N - X(I) = X(I)/AS(IA(I)) - ACC = X(I) - DO 280 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 280 CONTINUE - 300 CONTINUE - ELSE IF (UNI) THEN - DO 340 I = 1, N - ACC = X(I) - DO 320 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - AS(J)*ACC - 320 CONTINUE - 340 CONTINUE - END IF - END IF - ELSE IF (COTRA) THEN - DO 580 I = 1, N - X(I) = B(I) - 580 CONTINUE - IF (LOW) THEN - IF (.NOT.UNI) THEN - DO 620 I = N, 1, -1 - X(I) = X(I)/CONJG(AS(IA(I+1)-1)) - ACC = X(I) - DO 600 J = IA(I), IA(I+1) - 2 - K = JA(J) - X(K) = X(K) - CONJG(AS(J))*ACC - 600 CONTINUE - 620 CONTINUE - ELSE IF (UNI) THEN - DO 660 I = N, 1, -1 - ACC = X(I) - DO 640 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - CONJG(AS(J))*ACC - 640 CONTINUE - 660 CONTINUE - END IF - ELSE IF (.NOT.LOW) THEN - IF (.NOT.UNI) THEN - DO 700 I = 1, N - X(I) = X(I)/CONJG(AS(IA(I))) - ACC = X(I) - DO 680 J = IA(I) + 1, IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - CONJG(AS(J))*ACC - 680 CONTINUE - 700 CONTINUE - ELSE IF (UNI) THEN - DO 740 I = 1, N - ACC = X(I) - DO 720 J = IA(I), IA(I+1) - 1 - K = JA(J) - X(K) = X(K) - CONJG(AS(J))*ACC - 720 CONTINUE - 740 CONTINUE - END IF - END IF - END IF - RETURN - END - - - diff --git a/base/serial/dp/Makefile b/base/serial/dp/Makefile deleted file mode 100644 index 7b1ed7ca1..000000000 --- a/base/serial/dp/Makefile +++ /dev/null @@ -1,60 +0,0 @@ -include ../../../Make.inc -# -# The object files -# - -XOBJS = -#scrjd.o ccrjd.o zcrjd.o -FOBJS = partition.o dgblock.o dvtfg.o \ - check_dim.o \ - Max_nnzero.o \ - gen_block.o - #\ -# ccoco.o ccocr.o ccrco.o ccrcr.o cgindex.o cgind_tri.o\ -# zcoco.o zcocr.o zcrco.o zcrcr.o zgindex.o zgind_tri.o\ -# $(XOBJS) - -#dcoco.o dcocr.o dcrco.o djdcox.o djdco.o dgind_tri.o \ -#dcrcr.o -#dgindex.o djadrp.o djadrp1.o dcsrrp.o dcsrp1.o -#dcrjd.o -# scrco.o scrcr.o scocr.o scoco.o sgindex.o sgind_tri.o\ - -# -# dgind_tri.o -# - - -OBJS=$(FOBJS) - -# -# Where the library should go, and how it is called. -# Note that we are regenerating most of libsparker.a on the fly. -SPARKERDIR=.. -LIBDIR=../.. -MODDIR=../../modules -FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG)$(SPARKERDIR) $(FMFLAG). - -#LIBNAME=libsparker.a -LIBFILE=$(LIBDIR)/$(LIBNAME) - -# -# No change should be needed below -# - - -lib: $(FOBJS) - $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) - $(RANLIB) $(LIBDIR)/$(LIBNAME) - -xobjs: - (make $(XOBJS) FCOPT="$(FCOPT) $(EXTRA_OPT)") - -clean: cleanobjs - -veryclean: cleanobjs - -cleanobjs: - /bin/rm -f $(OBJS) - - diff --git a/base/serial/dp/Max_nnzero.f b/base/serial/dp/Max_nnzero.f deleted file mode 100644 index a63dcdb0c..000000000 --- a/base/serial/dp/Max_nnzero.f +++ /dev/null @@ -1,48 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - INTEGER FUNCTION MAX_NNZERO(M, IA2) - IMPLICIT NONE - - INTEGER M - INTEGER IA2(*) - - INTEGER I,MAX_NZ - - MAX_NZ = 0 - - DO I = 1, M - MAX_NZ = MAX(MAX_NZ,IA2(I+1)- IA2(I)) - ENDDO - - MAX_NNZERO = MAX_NZ - END - diff --git a/base/serial/dp/ccoco.f b/base/serial/dp/ccoco.f deleted file mode 100644 index 2fdc279c3..000000000 --- a/base/serial/dp/ccoco.f +++ /dev/null @@ -1,306 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -c covert matrix from COO format to COO format -c - subroutine ccoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, - * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, - * lia2n,aux,laux,ierror) - use psb_error_mod - use psb_const_mod - use psb_spmat_type - use psb_string_mod - use psb_ip_reord_mod - implicit none - -c .. scalar arguments .. - integer larn, laux, lia1n, lia2n, - + m, n, ierror - character trans,unitd -c .. array arguments .. - complex(psb_spk_) :: ar(*), arn(*), d(*) - integer aux(0:laux-1) - integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*), - * infon(*), p1(*), p2(*) - character descra*11, descrn*11 -c .. local scalars .. - integer ipx, ip1, ip2, check_flag, err_act - integer nnz, k, i, j, nzl, iret - integer elem_in, elem_out - logical scale - integer max_nnzero - integer :: debug_level, debug_unit -c .. local arrays .. - character*20 name - integer int_val(5) -c -c ...common variables... -c this flag describe the action to do - -c .. external subroutines .. - external max_nnzero -c .. executable statements .. -c - - name = 'ccoco' - ierror = 0 - call fcpsb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - - if (psb_toupper(trans).eq.'N') then - scale = (psb_toupper(unitd).eq.'L') ! meaningless - p1(1) = 0 - p2(1) = 0 - - call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror) - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': on entry nnz laux ', - + nnz,laux,larn,lia1n,lia2n - endif - if (laux.lt.nnz+2) then - ierror = 60 - int_val(1) = 22 - int_val(2) = nnz+2 - int_val(3) = laux - else if (larn.lt.nnz) then - ierror = 60 - int_val(1) = 18 - int_val(2) = nnz+2 - int_val(3) = laux - else if (lia1n.lt.nnz) then - ierror = 60 - int_val(1) = 19 - int_val(2) = nnz+2 - int_val(3) = laux - else if (lia2n.lt.m+1) then - ierror = 60 - int_val(1) = 20 - int_val(2) = nnz+2 - int_val(3) = laux - endif - -c -c error handling -c - if(ierror.ne.0) then - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - end if - - if (psb_toupper(descra(1:1)).eq.'G') then -c -c sort COO data structure -c - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': first sort',nnz - do k=1, nnz - arn(k) = ar(k) - ia1n(k) = ia1(k) - ia2n(k) = ia2(k) - enddo - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': second sort' - - if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1)) - + .and.(laux.ge.2*(2+nnz))) then -c -c prepare for smart regeneration -c - ipx = nnz+3 - do i=1, nnz - aux(ipx+i-1) = i - enddo - ip1 = nnz+2 - infon(psb_upd_pnt_) = ip1 - ip2 = ip1+psb_ireg_flgs_ - ia2n(ip1+psb_ip2_) = ip2 - ia2n(ip1+psb_iflag_) = check_flag - ia2n(ip1+psb_nnzt_) = nnz - ia2n(ip1+psb_nnz_) = 0 - ia2n(ip1+psb_ichk_) = nnz+check_flag - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': build check :',ia2n(ip1+psb_nnzt_) - -c .... order with key ia1n ... - call msort_up(nnz,ia1n,aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn, - + ia1n,ia2n,aux(ipx:),aux) -c .... order with key ia2n ... - - i = 1 - j = i - do while (i.le.nnz) - do while ((ia1n(j).eq.ia1n(i)).and. - + (j.le.nnz)) - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ia2n(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1), - + aux(ipx+i-1:ipx+i+nzl-1),aux) - i = j - enddo - - ia2n(ip2+aux(ipx+1-1)-1) = 1 - -c ... construct final COO representation... - elem_out = 1 -c ... insert remaining element ... - do elem_in = 2, nnz - if ((ia1n(elem_in).eq.ia1n(elem_out)).and. - + (ia2n(elem_in).eq.ia2n(elem_out))) then - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the first duplicated element ... - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_out) = arn(elem_out) + arn(elem_in) - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - end if - else - elem_out = elem_out + 1 - arn(elem_out) = arn(elem_in) - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - ia1n(elem_out) = ia1n(elem_in) - ia2n(elem_out) = ia2n(elem_in) - endif - enddo - - else - -c .... order with key ia1n ... - call msort_up(nnz,ia1n,aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn, - + ia1n,ia2n,aux) - -c .... order with key ia2n ... - - i = 1 - j = i - do while (i.le.nnz) - do while ((ia1n(j).eq.ia1n(i)).and. - + (j.le.nnz)) - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ia2n(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1),aux) - i = j - enddo -c ... construct final COO representation... - elem_out = 1 -c ... insert remaining element ... - do elem_in = 2, nnz - if ((ia1n(elem_in).eq.ia1n(elem_out)).and. - + (ia2n(elem_in).eq.ia2n(elem_out))) then - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the first duplicated element ... - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_out) = arn(elem_out) + arn(elem_in) - end if - else - elem_out = elem_out + 1 - arn(elem_out) = arn(elem_in) - ia1n(elem_out) = ia1n(elem_in) - ia2n(elem_out) = ia2n(elem_in) - endif - enddo - endif - infon(psb_nnz_) = elem_out - infon(psb_srtd_) = psb_isrtdcoo_ - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': done rebuild COO',infon(1) - - else if (psb_toupper(descra(1:1)).eq.'S' .and. - + psb_toupper(descra(2:2)).eq.'U') then - - do 20 k = 1, m - p2(k) = k - 20 continue - - else if (psb_toupper(descra(1:1)).eq.'T' .and. - + psb_toupper(descra(2:2)).eq.'U') then - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - - else if (psb_toupper(descra(1:1)).eq.'T' .and. - + psb_toupper(descra(2:2)).eq.'L') then - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if -c - else if (psb_toupper(trans).ne.'N') then -c -c to do -c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if - - call fcpsb_erractionrestore(err_act) - return - - 9999 continue - call fcpsb_erractionrestore(err_act) - - if ( err_act .ne. 0 ) then - call fcpsb_serror() - return - endif - - return - end diff --git a/base/serial/dp/ccocr.f b/base/serial/dp/ccocr.f deleted file mode 100644 index af210f2bc..000000000 --- a/base/serial/dp/ccocr.f +++ /dev/null @@ -1,523 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Covert matrix from COO format to CSR Format -C Note: this never sets IP1 and P2! -C - SUBROUTINE CCOCR(TRANS,M,N,UNITD,D,DESCRA,AR,JA,IA,INFO, - * P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1, - * LIAN2,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_ip_reord_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, - + N, IUPDUP, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - complex(psb_spk_) AR(*), ARN(*), D(*) - INTEGER AUX(0:LAUX-1) - INTEGER JA(*), IA(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), P1(*), P2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - integer nnz, k, row, i, j, nzl, iret - integer ipx, ip1, ip2, check_flag, err_act - integer elem, elem_csr,regen_flag - logical scale - integer max_nnzero - integer, allocatable :: itmp(:) -c .. local arrays .. - character*20 name - integer int_val(5) - integer :: debug_level, debug_unit - -C -C ...Common variables... - -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - NAME = 'CCOCR' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - - IF (psb_toupper(TRANS).EQ.'N') THEN - - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - P1(1) = 0 - P2(1) = 0 - nnz = info(1) - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': On entry NNZ LAUX ', - + nnz,laux,larn,lian1,lian2 - endif - IF (LAUX.LT.NNZ+2) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ - INT_VAL(3) = LARN - ELSE IF (LIAN1.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN1 - ELSE IF (LIAN2.LT.M+1) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = M+1 - INT_VAL(3) = LIAN2 - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - allocate(itmp(nnz),stat=iret) - if (iret /= 0) then - call fcpsb_errpush(4010,name,int_val) - goto 9999 - end if - - do k=1, nnz - arn(k) = ar(k) - ian1(k) = ja(k) - itmp(k) = ia(k) - enddo - ! Mark as unavailable by default. - infon(psb_upd_pnt_) = 0 - - - IF (psb_toupper(descra(1:1)).EQ.'G') THEN -C -C Sort COO data structure -C - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': First sort',nnz - - if ((regen_flag==psb_upd_perm_).and. - + (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) - + .and.(laux.ge.2*(2+nnz))) then -C -C Prepare for smart regeneration -c - ipx = nnz+3 - do i=1, nnz - aux(ipx+i-1) = i - enddo - ip1 = m+2 - infon(psb_upd_pnt_) = ip1 - ip2 = ip1+psb_ireg_flgs_ - ian2(ip1+psb_ip2_) = ip2 - ian2(ip1+psb_iflag_) = check_flag - ian2(ip1+psb_nnzt_) = nnz - ian2(ip1+psb_nnz_) = 0 - ian2(ip1+psb_ichk_) = nnz+check_flag - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Build check :',ian2(ip1+psb_nnzt_) - -C .... Order with key IA ... - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux(ipx:),aux) - - if (debug_level >= psb_debug_serial_) then - do i=1, nnz-1 - if (itmp(i).gt.itmp(i+1)) then - write(debug_unit,*) trim(name), - + 'Sorting error:',i,itmp(i),itmp(i+1) - endif - enddo - write(debug_unit,*) trim(name), - + 'nnz :',m,nnz,itmp(nnz),ian1(nnz) - endif - -C .... Order with key JA ... - - I = 1 - J = I - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1), - + aux(ipx+i-1:ipx+i+nzl-1),aux) - i = j - enddo - -c ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -c ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem = elem+1 - elem_csr = elem_csr+1 -c ... insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -c ... insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - - else -C .... Order with key IA ... - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - - i = j - enddo - - - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - endif - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': Done Rebuild CSR', - + ian2(m+1),ia(elem) - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - do 20 k = 1, m - p2(k) = k - 20 continue - - else if (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - i = j - enddo - - - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - else if (psb_toupper(descra(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') THEN - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - i = j - enddo - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': Done Rebuild CSR', - + ian2(m+1),ia(elem) - - - end if -c - else if (psb_toupper(TRANS).NE.'N') then -c -c to do -c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if - infon(1)=elem_csr-1 - - call fcpsb_erractionrestore(err_act) - return - - 9999 continue - call fcpsb_erractionrestore(err_act) - - if ( err_act .ne. 0 ) then - call fcpsb_serror() - return - endif - - return - end diff --git a/base/serial/dp/ccrco.f b/base/serial/dp/ccrco.f deleted file mode 100644 index 7767eed67..000000000 --- a/base/serial/dp/ccrco.f +++ /dev/null @@ -1,168 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE CCRCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, - * LIAN2,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_spmat_type - use psb_string_mod - use psb_error_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LIAN1, LIAN2, M, N, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - complex(psb_spk_) AR(*), ARN(*), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER NNZ, K, ROW, J - INTEGER ELEM, ERR_ACT - LOGICAL SCALE - INTEGER MAX_NNZERO -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - integer :: debug_level, debug_unit -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - - NAME = 'CCRCO' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF (psb_toupper(TRANS).EQ.'N') THEN - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - IP1(1) = 0 - IP2(1) = 0 - NNZ = IA2(M+1)-1 - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': entry',m,n,nnz, - + ' : ',descra,' : ',descrn - - IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ - INT_VAL(3) = LARN - ELSE IF (LIAN1.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN1 - ELSE IF (LIAN2.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN2 - ENDIF - - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN -C ... Construct COO Representation... - ELEM = 0 - - DO ROW = 1, M - DO J = IA2(ROW), IA2(ROW+1)-1 - ELEM = ELEM + 1 - IAN1(ELEM) = ROW - IAN2(ELEM) = IA1(J) - ARN(ELEM) = AR(J) - ENDDO - ENDDO - INFON(psb_nnz_) = elem - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': endloop',m,elem - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 -C - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - -C - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') THEN - - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - END IF -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO DO -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/ccrcr.f b/base/serial/dp/ccrcr.f deleted file mode 100644 index 9f42e05a4..000000000 --- a/base/serial/dp/ccrcr.f +++ /dev/null @@ -1,315 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE CCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, -C DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, -C WORK,LWORK,IERROR) -C -C Purpose: CSR to CSR format conversion -C ======= -C -C Parameter: -C ========= -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will convert -C matrix A or the transpose of A as follows: -C TRANS = 'N' -> convert matrix A -C TRANS = 'T' or 'C' -> convert A' (the transpose of A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') -C and number of rows of matrix H -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A (A') -C and number of columns of matrix H -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - DOUBLE PRECISION array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IP1 - INTEGER array of dimension (M) -C On exit IP1 specifies the row permutation of matrix AN -C (IP1(1) == 0 if no permutation). -C -C DESCRN - CHARACTER*1 array of DIMENSION (9) -C On exit DESCRN describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C AN - DOUBLE PRECISION array of DIMENSION (LAN) -C On exit AN specifies the values of the output sparse -C matrix. If LAN=0, INT(AN(1)) is the minimum value for LAN -C satisfying DSPDP memory requirements. -C -C IAN1 - INTEGER array of dimension (LIAN1) -C On exit IAN1 holds integer information on output sparse -C matrix. Actual information will depend on data format used. -C If LIAN1=0, INT(IAN1(1)) is the minimum value for LIAN1 -C satisfying DSPDP memory requirements. -C -C IAN2 - INTEGER array of dimension (LIAN2) -C On exit IAN2 holds integer information on output sparse -C matrix. Actual information will depend on data format used. -C If LIAN2=0, INT(IAN2(1)) is the minimum value for LIAN2 -C satisfying DSPDP memory requirements. -C -C INFON - INTEGER array of dimension (10) -C On exit can hold auxiliary information on output matrices -C formats or environment of subsequent calls. -C -C IP2 - INTEGER array of dimension (M) -C On exit IP2 specifies the column permutation of matrix AN -C (IP2(1) == 0 if no permutation). -C -C LAN - INTEGER -C On entry LAN specifies the dimension of AN -C LAN must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C LIAN1 - INTEGER -C On entry LH1 specifies the dimension of IAN1 -C LH1 must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C LIAN2 - INTEGER -C On entry LIAN2 specifies the dimension of IAN2 -C LIAN2 must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPDP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK must satisfy memory necessary for the data conversion. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 error -C -C - SUBROUTINE CCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, - * DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, - * WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C -C .. Scalar Arguments .. - INTEGER M, N, LAN, LIAN1, LIAN2, LWORK, IERROR - CHARACTER TRANS, UNITD -C .. Array Arguments .. - complex(psb_spk_) A(*), AN(*), D(*), WORK(LWORK) - INTEGER IA1(*), IA2(*), IAN1(*), IAN2(*), IP1(*), IP2(*), - * INFOA(*), INFON(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER I, J, ERR_ACT - LOGICAL EXIT -c .. Local Arrays .. - character idescra*11 - CHARACTER*20 NAME - INTEGER INT_VAL(5) - -C .. Intrinsic Functions .. - INTRINSIC DBLE, DSQRT - -C .. Executable Statements .. -C - EXIT=.FALSE. - NAME = 'CCRCR' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) -C -C Check for argument errors -C - idescra=psb_toupper(descra) - IF(((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. - & IDESCRA(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .NE. 'B')).OR. - & (.NOT.((IDESCRA(3:3).EQ.'N').OR.(IDESCRA(3:3).EQ.'L').OR. - + (IDESCRA(3:3).EQ.'U'))) .OR. - + psb_toupper(TRANS).NE.'N') THEN - IERROR = 20 - ENDIF - IF(LAN.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - AN(1) = REAL(IA2(M+1)-1) - ELSE - IERROR = 21 - ENDIF - ENDIF - IF(LIAN1.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN1(1) = IA2(M+1)-1 - ELSE - IERROR = 22 - ENDIF - ENDIF - IF(LIAN2.LT.(M+1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN2(1) = M+1 - ELSE - IERROR = 23 - ENDIF - ENDIF - IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. - & IDESCRA(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .EQ. 'B')) THEN - IF (LWORK.LT.M) THEN - IF (LWORK.LE.0) THEN - EXIT=.TRUE. - ELSE - IERROR = 25 - ENDIF - WORK(1) = DBLE(M) - ENDIF - ELSE - IF (LWORK.LT.0) THEN - WORK(1) = 0.D0 - ENDIF - ENDIF -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (EXIT) goto 9998 -C -C Set DESCRN, IP1, IP2 -C - DESCRN(1:3) = IDESCRA(1:3) - - IP1(1)=0 - IP2(1)=0 -C -C Compute output matrix -C - DO 20 I = 1, M+1 - IAN2(I) = IA2(I) - 20 CONTINUE - IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. - & IDESCRA(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .EQ. 'B')) THEN - DO 30 I = 1, M - WORK(I) = REAL(SQRT(ABS(D(I)))) - 30 CONTINUE - DO 40 I = 1, M - DO 50 J = IA2(I), IA2(I+1)-1 - AN(J) = WORK(I) * A(J) * WORK(IA1(J)) - IAN1(J) = IA1(J) - 50 CONTINUE - 40 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'L') THEN - DO 60 I = 1, M - DO 70 J = IA2(I), IA2(I+1)-1 - AN(J) = D(I) * A(J) - IAN1(J) = IA1(J) - 70 CONTINUE - 60 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'R') THEN - DO 80 I = 1, M - DO 90 J = IA2(I), IA2(I+1)-1 - AN(J) = A(J) * D(IA1(J)) - IAN1(J) = IA1(J) - 90 CONTINUE - 80 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'U') THEN - DO 100 J = 1, IA2(M+1)-1 - AN(J) = A(J) - IAN1(J) = IA1(J) - 100 CONTINUE - ENDIF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - - diff --git a/base/serial/dp/ccrjd.f b/base/serial/dp/ccrjd.f deleted file mode 100644 index 59d87c3d4..000000000 --- a/base/serial/dp/ccrjd.f +++ /dev/null @@ -1,315 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE CCRJD(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, - * LIAN2,AUX,LAUX,SIZE_REQ,IERROR) -C -C Purpose -C ======= -C -C CCRJD converts a CSR matrix into a Jagged Diagonal. -C -C -C Notes -C ===== -C -C Parameters -C ========== -C -C TRANS Whether the transpose should be converted. -C -C M,N Size of input matrix A -C -C UNITD Scaling by diagonal D: 'U'nit, 'L'eft, 'R'ight -C D(*) -C -C DESCRA Input matrix A. -C AR,IA1, -C IA2,INFO -C -C DESCRN Output matrix in JAD format -C ARN,IAN1 -C IAN2,INFON, IP1, IP2 -C - use psb_const_mod - use psb_spmat_type - use psb_string_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, N, - * SIZE_REQ, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - complex(psb_spk_) AR(*), ARN(*), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER IOFF, ISTROW, NJA, NZ, PIA, - + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT - LOGICAL SCALE - CHARACTER UPLO - INTEGER MAX_NNZERO -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5), IERRV(5) - -C .. External Subroutines .. - EXTERNAL DVTFG - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - NAME = 'CCRJD' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (LAUX.LT.4) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = 4 - INT_VAL(3) = LAUX - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IF (psb_toupper(TRANS).EQ.'N') THEN -C - NJA = 3*M - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - IOFF = 5 -C -C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX -C - PNG = IOFF - PIA = PNG + 1 - PJA = PIA + 3*(M+2) - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN - -C -C CHECK ON DIMENSION OF IAN2 AND AUX -C - MAX_NG = M/PSB_MINJDROWS_+1 - - IF ((PIA+3*(MAX_NG+1).GT.LIAN2).OR.(M+1 .GT. LAUX)) THEN -C ... If I haven't sufficent memory to compute NG in IAN2 ... - IF (M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1.GT.LAUX) THEN -C ... If I haven't sufficent memory to compute NG in AUX ... - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1 - INT_VAL(3) = LAUX - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE -C ... I have sufficent memory to compute NG in AUX ... - CALL DGBLOCK(M,IA2,IP1,AUX(M+2),NG, AUX, LAUX) - CALL CHECK_DIM(M,N,AUX(M+2),NG,IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - IF (IERRV(1).NE.0) THEN - SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) - - GOTO 9998 - ENDIF - ENDIF - END IF - - NZ = IA2(M+1) - 1 -C -C ... Initialize Permutation Matrix ... -C - DO 10 K = 1, M - IP1(K) = K - 10 CONTINUE - - IP2(1) = 0 - - CALL DGBLOCK(M,IA2,IP1,IAN2(PIA),IAN2(PNG), AUX, LAUX) - - PJA = PIA + 3*(IAN2(PNG)+1) -C -C CHECK FOR ARRAY DIMENSIONS -C - CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - IF (IERRV(1) .NE.0) THEN - SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) - GOTO 9998 - ENDIF - - LJA = LIAN2-PJA - CALL CGINDEX(M,IAN2(PNG),AR,IA1,IA2,info, - + ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON, - + LARN,LIAN1, LJA,IP1, - + AUX, LAUX*2, SIZE_REQ,IERROR) - - IF (IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - DESCRN(1:1) = 'G' - DESCRN(2:2) = 'U' - DESCRN(3:3) = 'N' - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN -C - ISTROW = 1 - NZ = 2*(IA2(M+1)-1) - M -C -C CHECK ON DIMENSION OF IAN1 AND ARN -C - IF (NZ .GT. LIAN1) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NZ - INT_VAL(3) = LAUX - LIAN1 = NZ - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (NZ .GT. LARN) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NZ - INT_VAL(3) = LAUX - LIAN1 = NZ - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - -c$$$ CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$ * AUX(IWORK1)) -c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), -c$$$ * AUX(IWORK2),NJA,IER,SCALE) -C - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T') THEN -C -C Only unit diagonal so far for triangular matrices. -C - - - IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN - IERROR=3022 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - UPLO = DESCRA(2:2) - NZ = IA2(M+1) - 1 -C -C ...Compute levels... -C Each level correspond to a block -C IAN1 is used as a work area - - CALL DVTFG(UPLO,M,IA1,IA2,IAN2(PNG),IP2,IP1,IAN1, - + AUX,AUX(M+1),AUX(2*(M+1))) - -C Generate IA(1,*) - DO K = 1, IAN2(PNG)+1 - IAN2(PIA+3*(K-1)) = IAN1(K) - ENDDO - - CALL GEN_BLOCK(M,IAN2(PNG),IAN2(PIA),AUX) - - PJA = PIA + 3*(IAN2(PNG)+1) - -C -C CHECK FOR ARRAY DIMENSIONS -C - - CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - - IF (IERRV(1).NE.0) THEN - size_req = max(ierrv(2),ierrv(3),ierrv(4)) -c$$$ write(0,*) "error 2",ierrv(1) - GOTO 9998 - endif - LJA = LIAN2-PJA - - CALL CGIND_TRI(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), - + IAN2(PJA),LARN,LIAN1,LJA,IP1,AUX, LAUX, IERROR) - - IF (IERROR.NE.0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - DESCRN(1:1) = 'T' - DESCRN(2:3) = psb_toupper(DESCRA(2:3)) - - END IF -C -C SET THE OUTPUT PARAMETER -C - IAN2(1) = PNG - IAN2(2) = PIA - IAN2(3) = PJA - LARN = NZ - LIAN1 = NZ - LIAN2 = 3*M + 10 - LAUX2 = 4*M + 2 -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO BE DONE -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/cgind_tri.f b/base/serial/dp/cgind_tri.f deleted file mode 100644 index fa3bc9719..000000000 --- a/base/serial/dp/cgind_tri.f +++ /dev/null @@ -1,237 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE CGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, - + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) - - use psb_const_mod - IMPLICIT NONE - -C ... Scalar arguments ... - - INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, IERROR - -C ... Array arguments ... - - complex(psb_spk_) A(*), ARN(*), WORK(*) - INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(M), JA(*) - -C .... Local scalars ... - INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, - + DIM_BLOCK, LIMIT, ERR_ACT - LOGICAL CSR -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'CGIND_TRI\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - POINT_AR = 1 - POINT_JA = 0 - IERROR = 0 - - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C .... Invert Permutation Matrix... - IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO - ENDIF - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - ARN(POINT_AR) = 0.D0 -C -C The following statement assumes that we never get here with POINT_AR=1 -C - KA (POINT_AR) = KA(POINT_AR-1) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IPERM(IA1(IA2(ROW)+COL-1)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - 998 CONTINUE - - ENDIF - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IPERM(IA1(J)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - IA(2,N_BLOCKS+1) = POINT_JA - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/cgindex.f b/base/serial/dp/cgindex.f deleted file mode 100644 index 43a3a0d13..000000000 --- a/base/serial/dp/cgindex.f +++ /dev/null @@ -1,463 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE CGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON, - + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) - - use psb_const_mod - use psb_spmat_type - IMPLICIT NONE - -C ... Scalar arguments ... - INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, - + SIZE_REQ,IERROR - -C ... Array arguments ... - - complex(psb_spk_) A(*), ARN(*) - INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*), infoa(*) - -C .... Local scalars ... - INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1, - + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG, - + ERR_ACT, ix, regen_flag - LOGICAL CSR -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'CGINDEX\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - POINT_AR = 1 - POINT_JA = 0 - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - - - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - NNZ = IA2(M + 1) - 1 - COUNT = 0 - -C .... Invert Permutation Matrix... - IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO - ENDIF - - size_Req=0 - - IF ( (regen_flag == psb_upd_perm_) - + .AND. (LWORK .GE. (M + NNZ+2))) THEN -C -C Prepare for smart regeneration -C - - IPW = M + 2 - IP1 = (LKA-PSB_IREG_FLGS_-2)/2 - IP2 = IP1+PSB_IREG_FLGS_ - IPC = IP2 + NNZ + 1 - KA(IP1 + PSB_IPC_) = IPC - KA(IP1+PSB_IP2_) = IP2 - INFON(PSB_UPD_PNT_) = IP1 - KA(IP1+PSB_IFLAG_) = CHECK_FLAG - KA(IP1+PSB_NNZT_) = NNZ - KA(IP1+PSB_NNZ_) = 0 - KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG - - if (infoa(psb_upd_pnt_) > 0) then - I = infoa(psb_upd_pnt_) - IPX = IA2(I+PSB_IP2_) -C Invert permutation for smart regeneration - - DO I = 1, NNZ - WORK(IPW + IA2(IPX + I -1) - 1) = I - ENDDO - else -! No permutation available before, set identity. - DO I = 1, NNZ - WORK(IPW + I - 1) = I - ENDDO - endif -C Construct JAD matrix... - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) -c$$$ write(0,*) 'CGINDEX: BLOCK LOOP ',block,n_blocks,dim_block - if (dim_block .gt. PSB_MAXJDROWS_) then - write(0,*) 'Wrong value for dim_block',block, - + IA(1,BLOCK+1),IA(1,BLOCK) - return - endif - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - - COUNT = COUNT + 1 - ARN(POINT_AR) = 0.D0 - KA(POINT_AR) = KA(POINT_AR-1) - IF(POINT_AR.LT.IP1) THEN - KA(IPC + COUNT -1) = POINT_AR - ENDIF -C -C The following statement assumes that we never get here with POINT_AR=1 -C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA(POINT_AR) = IA1(IA2(ROW)+COL-1) - IF(POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + - + IA2(ROW) +COL -1-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF(IERROR.EQ.0) THEN - JA(POINT_JA+COL) = POINT_AR - ENDIF - COL = COL+1 - ENDDO - - ENDIF - 998 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - IF (POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + J-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - IA(2,N_BLOCKS+1) = POINT_JA - KA(IP1 + PSB_ZERO_) = COUNT - - IF (POINT_AR.GE.IP1) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF - - ELSE -c$$$ c write(*,*)'inizio a ciclare sui blocchi' - IP1 = LKA - PSB_ZERO_ - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 999 - ELSE - COUNT= COUNT+1 - ARN(POINT_AR) = 0.D0 - KA (POINT_AR) = KA(POINT_AR-1) -C -C The following statement assumes that we never get here with POINT_AR=1 -C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IA1(IA2(ROW)+COL-1) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 999 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - - ENDIF - 999 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - - - IA(2,N_BLOCKS+1) = POINT_JA - - IF (POINT_AR.GE.lka) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF - ENDIF - - infon(1)=point_ar-1 - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/check_dim.f b/base/serial/dp/check_dim.f deleted file mode 100644 index d8148fc64..000000000 --- a/base/serial/dp/check_dim.f +++ /dev/null @@ -1,88 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE CHECK_DIM(M, N, IA, NG, IA2, - + NZ, LARN, LIAN1, LIAN2, IERRV) - - use psb_const_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER M,N,NG,LARN,LIAN1,LIAN2, NZ - -C .. Array Arguments .. - INTEGER IA(3,*), IA2(*), IERRV(*) - -C Local scalars - INTEGER NNZ, BLOCK, DIM_BLOCK, LIMIT - INTEGER MAX_NNZERO, MAX_NZ - - EXTERNAL MAX_NNZERO - - MAX_NZ = MAX_NNZERO(M,IA2) - - NNZ = NZ - -c$$$ LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - - DO BLOCK = 1, NG - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - - NNZ = NNZ+(DIM_BLOCK-LIMIT)*MAX_NZ - END DO - - IERRV(1)=0 - IERRV(2) = NNZ - IERRV(3) = NNZ - IERRV(4) = 6+3*(NG+1)+M+MAX_NZ*NG+1 - IF (6+3*(NG+1)+M+MAX_NZ*NG+1.GT.LIAN2) THEN - IERRV(1) = 30 -c$$$ write(0,*) 'check_dim: error 1', -c$$$ + 6+3*(NG+1)+M+MAX_NZ*NG+1,LIAN2 - ENDIF - - IF (NNZ.GT.LIAN1) THEN -c$$$ write(0,*) 'check_dim: error 2',nnz,lian1 - IERRV(1) = 31 - ENDIF - - IF (NNZ.GT.LARN) THEN -c$$$ write(0,*) 'check_dim: error 3',nnz,larn - IERRV(1) = 32 - ENDIF - - RETURN - END - - - diff --git a/base/serial/dp/dcoco.f b/base/serial/dp/dcoco.f deleted file mode 100644 index f49ad7b20..000000000 --- a/base/serial/dp/dcoco.f +++ /dev/null @@ -1,306 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -c covert matrix from COO format to COO format -c - subroutine dcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, - * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, - * lia2n,aux,laux,ierror) - use psb_error_mod - use psb_const_mod - use psb_spmat_type - use psb_string_mod - use psb_ip_reord_mod - implicit none - -c .. scalar arguments .. - integer larn, laux, lia1n, lia2n, - + m, n, ierror - character trans,unitd -c .. array arguments .. - real(psb_dpk_) ar(*), arn(*), d(*) - integer aux(0:laux-1) - integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*), - * infon(*), p1(*), p2(*) - character descra*11, descrn*11 -c .. local scalars .. - integer ipx, ip1, ip2, check_flag, err_act - integer nnz, k, i, j, nzl, iret - integer elem_in, elem_out - logical scale - integer max_nnzero - integer :: debug_level, debug_unit -c .. local arrays .. - character*20 name - integer int_val(5) -c -c ...common variables... -c this flag describe the action to do - -c .. external subroutines .. - external max_nnzero -c .. executable statements .. -c - - name = 'dcoco' - ierror = 0 - call fcpsb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - - if (psb_toupper(trans).eq.'N') then - scale = (psb_toupper(unitd).eq.'L') ! meaningless - p1(1) = 0 - p2(1) = 0 - - call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror) - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': on entry nnz laux ', - + nnz,laux,larn,lia1n,lia2n - endif - if (laux.lt.nnz+2) then - ierror = 60 - int_val(1) = 22 - int_val(2) = nnz+2 - int_val(3) = laux - else if (larn.lt.nnz) then - ierror = 60 - int_val(1) = 18 - int_val(2) = nnz+2 - int_val(3) = laux - else if (lia1n.lt.nnz) then - ierror = 60 - int_val(1) = 19 - int_val(2) = nnz+2 - int_val(3) = laux - else if (lia2n.lt.m+1) then - ierror = 60 - int_val(1) = 20 - int_val(2) = nnz+2 - int_val(3) = laux - endif - -c -c error handling -c - if(ierror.ne.0) then - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - end if - - if (psb_toupper(descra(1:1)).eq.'G') then -c -c sort COO data structure -c - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': first sort',nnz - do k=1, nnz - arn(k) = ar(k) - ia1n(k) = ia1(k) - ia2n(k) = ia2(k) - enddo - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': second sort' - - if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1)) - + .and.(laux.ge.2*(2+nnz))) then -c -c prepare for smart regeneration -c - ipx = nnz+3 - do i=1, nnz - aux(ipx+i-1) = i - enddo - ip1 = nnz+2 - infon(psb_upd_pnt_) = ip1 - ip2 = ip1+psb_ireg_flgs_ - ia2n(ip1+psb_ip2_) = ip2 - ia2n(ip1+psb_iflag_) = check_flag - ia2n(ip1+psb_nnzt_) = nnz - ia2n(ip1+psb_nnz_) = 0 - ia2n(ip1+psb_ichk_) = nnz+check_flag - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': build check :',ia2n(ip1+psb_nnzt_) - -c .... order with key ia1n ... - call msort_up(nnz,ia1n,aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn, - + ia1n,ia2n,aux(ipx:),aux) -c .... order with key ia2n ... - - i = 1 - j = i - do while (i.le.nnz) - do while ((ia1n(j).eq.ia1n(i)).and. - + (j.le.nnz)) - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ia2n(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1), - + aux(ipx+i-1:ipx+i+nzl-1),aux) - i = j - enddo - - ia2n(ip2+aux(ipx+1-1)-1) = 1 - -c ... construct final COO representation... - elem_out = 1 -c ... insert remaining element ... - do elem_in = 2, nnz - if ((ia1n(elem_in).eq.ia1n(elem_out)).and. - + (ia2n(elem_in).eq.ia2n(elem_out))) then - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the first duplicated element ... - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_out) = arn(elem_out) + arn(elem_in) - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - end if - else - elem_out = elem_out + 1 - arn(elem_out) = arn(elem_in) - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - ia1n(elem_out) = ia1n(elem_in) - ia2n(elem_out) = ia2n(elem_in) - endif - enddo - - else - -c .... order with key ia1n ... - call msort_up(nnz,ia1n,aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn, - + ia1n,ia2n,aux) - -c .... order with key ia2n ... - - i = 1 - j = i - do while (i.le.nnz) - do while ((ia1n(j).eq.ia1n(i)).and. - + (j.le.nnz)) - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ia2n(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1),aux) - i = j - enddo -c ... construct final COO representation... - elem_out = 1 -c ... insert remaining element ... - do elem_in = 2, nnz - if ((ia1n(elem_in).eq.ia1n(elem_out)).and. - + (ia2n(elem_in).eq.ia2n(elem_out))) then - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the first duplicated element ... - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_out) = arn(elem_out) + arn(elem_in) - end if - else - elem_out = elem_out + 1 - arn(elem_out) = arn(elem_in) - ia1n(elem_out) = ia1n(elem_in) - ia2n(elem_out) = ia2n(elem_in) - endif - enddo - endif - infon(psb_nnz_) = elem_out - infon(psb_srtd_) = psb_isrtdcoo_ - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': done rebuild COO',infon(1) - - else if (psb_toupper(descra(1:1)).eq.'S' .and. - + psb_toupper(descra(2:2)).eq.'U') then - - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - else if (psb_toupper(descra(1:1)).eq.'T' .and. - + psb_toupper(descra(2:2)).eq.'U') then - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - - else if (psb_toupper(descra(1:1)).eq.'T' .and. - + psb_toupper(descra(2:2)).eq.'L') then - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if -c - else if (psb_toupper(trans).ne.'N') then -c -c to do -c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if - - call fcpsb_erractionrestore(err_act) - return - - 9999 continue - call fcpsb_erractionrestore(err_act) - - if ( err_act .ne. 0 ) then - call fcpsb_serror() - return - endif - - return - end diff --git a/base/serial/dp/dcocr.f b/base/serial/dp/dcocr.f deleted file mode 100644 index 376eb58c6..000000000 --- a/base/serial/dp/dcocr.f +++ /dev/null @@ -1,524 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Covert matrix from COO format to CSR Format -C Note: this never sets IP1 and P2! -C - SUBROUTINE DCOCR(TRANS,M,N,UNITD,D,DESCRA,AR,JA,IA,INFO, - * P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1, - * LIAN2,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_ip_reord_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LIAN1, LIAN2, M, - + N, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - real(psb_dpk_) AR(*), ARN(*), D(*) - INTEGER AUX(0:LAUX-1) - INTEGER JA(*), IA(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), P1(*), P2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - integer nnz, k, row, i, j, nzl, iret - integer ipx, ip1, ip2, check_flag, err_act - integer elem, elem_csr,regen_flag - logical scale - integer max_nnzero - integer, allocatable :: itmp(:) -c .. local arrays .. - character*20 name - integer int_val(5) - integer :: debug_level, debug_unit - -c -C ...Common variables... - -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - - NAME = 'DCOCR' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - - IF (psb_toupper(TRANS).EQ.'N') THEN - - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - P1(1) = 0 - P2(1) = 0 - nnz = info(1) - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': On entry NNZ LAUX ', - + nnz,laux,larn,lian1,lian2 - endif - IF (LAUX.LT.NNZ+2) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ - INT_VAL(3) = LARN - ELSE IF (LIAN1.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN1 - ELSE IF (LIAN2.LT.M+1) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = M+1 - INT_VAL(3) = LIAN2 - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - allocate(itmp(nnz),stat=iret) - if (iret /= 0) then - call fcpsb_errpush(4010,name,int_val) - goto 9999 - end if - - do k=1, nnz - arn(k) = ar(k) - ian1(k) = ja(k) - itmp(k) = ia(k) - enddo - ! Mark as unavailable by default. - infon(psb_upd_pnt_) = 0 - - - IF (psb_toupper(descra(1:1)).EQ.'G') THEN -C -C Sort COO data structure -C - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': First sort',nnz - - if ((regen_flag==psb_upd_perm_).and. - + (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) - + .and.(laux.ge.2*(2+nnz))) then -C -C Prepare for smart regeneration -c - ipx = nnz+3 - do i=1, nnz - aux(ipx+i-1) = i - enddo - ip1 = m+2 - infon(psb_upd_pnt_) = ip1 - ip2 = ip1+psb_ireg_flgs_ - ian2(ip1+psb_ip2_) = ip2 - ian2(ip1+psb_iflag_) = check_flag - ian2(ip1+psb_nnzt_) = nnz - ian2(ip1+psb_nnz_) = 0 - ian2(ip1+psb_ichk_) = nnz+check_flag - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Build check :',ian2(ip1+psb_nnzt_) - -C .... Order with key IA ... - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux(ipx:),aux) - - if (debug_level >= psb_debug_serial_) then - do i=1, nnz-1 - if (itmp(i).gt.itmp(i+1)) then - write(debug_unit,*) trim(name), - + 'Sorting error:',i,itmp(i),itmp(i+1) - endif - enddo - write(debug_unit,*) trim(name), - + 'nnz :',m,nnz,itmp(nnz),ian1(nnz) - endif - -C .... Order with key JA ... - - I = 1 - J = I - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1), - + aux(ipx+i-1:ipx+i+nzl-1),aux) - i = j - enddo - -c ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -c ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem = elem+1 - elem_csr = elem_csr+1 -c ... insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -c ... insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - - else -C .... Order with key IA ... - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - - i = j - enddo - - - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - endif - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': Done Rebuild CSR', - + ian2(m+1),ia(elem) - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - do 20 k = 1, m - p2(k) = k - 20 continue - - else if (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - i = j - enddo - - - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - else if (psb_toupper(descra(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') THEN - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - i = j - enddo - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': Done Rebuild CSR', - + ian2(m+1),ia(elem) - - - end if -c - else if (psb_toupper(TRANS).NE.'N') then -c -c to do -c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if - infon(1)=elem_csr-1 - - call fcpsb_erractionrestore(err_act) - return - - 9999 continue - call fcpsb_erractionrestore(err_act) - - if ( err_act .ne. 0 ) then - call fcpsb_serror() - return - endif - - return - end diff --git a/base/serial/dp/dcrco.f b/base/serial/dp/dcrco.f deleted file mode 100644 index 25f9cd3a2..000000000 --- a/base/serial/dp/dcrco.f +++ /dev/null @@ -1,193 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DCRCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, - * LIAN2,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_spmat_type - use psb_string_mod - use psb_error_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LIAN1, LIAN2, M, N, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - real(psb_dpk_) AR(*), ARN(*), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER NNZ, K, ROW, J - INTEGER ELEM, ERR_ACT - LOGICAL SCALE - INTEGER MAX_NNZERO -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - integer :: debug_level, debug_unit -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - - NAME = 'DCRCO' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF (psb_toupper(TRANS).EQ.'N') THEN - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - IP1(1) = 0 - IP2(1) = 0 - NNZ = IA2(M+1)-1 - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': entry',m,n,nnz, - + ' : ',descra,' : ',descrn - - IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ - INT_VAL(3) = LARN - ELSE IF (LIAN1.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN1 - ELSE IF (LIAN2.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN2 - ENDIF - - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN -C ... Construct COO Representation... - ELEM = 0 - - DO ROW = 1, M - DO J = IA2(ROW), IA2(ROW+1)-1 - ELEM = ELEM + 1 - IAN1(ELEM) = ROW - IAN2(ELEM) = IA1(J) - ARN(ELEM) = AR(J) - ENDDO - ENDDO - INFON(psb_nnz_) = elem - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': endloop',m,elem - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 -c$$$ CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$ * AUX(IWORK1)) -c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), -c$$$ * AUX(IWORK2),NJA,IER,SCALE) -C - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - -c$$$ CALL DVTFG('U',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$c * AUX(IWORK1),AUX(IWORK2),IAN1(M+1)) -c$$$ * AUX(IWORK1),IAN1(1),IAN1(M+5)) -c$$$ CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE) -C - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') THEN - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - -c$$$ CALL DVTFG('L',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$c * AUX(IWORK1),AUX(IWORK2),IAN1(M+1)) -c$$$ * AUX(IWORK1),IAN1(1),IAN1(M+5)) -c$$$ CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE) - else - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - END IF -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO DO -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - else - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/dcrcr.f b/base/serial/dp/dcrcr.f deleted file mode 100644 index 92b8f4cc7..000000000 --- a/base/serial/dp/dcrcr.f +++ /dev/null @@ -1,319 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, -C DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, -C WORK,LWORK,IERROR) -C -C Purpose: CSR to CSR format conversion -C ======= -C -C Parameter: -C ========= -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will convert -C matrix A or the transpose of A as follows: -C TRANS = 'N' -> convert matrix A -C TRANS = 'T' or 'C' -> convert A' (the transpose of A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') -C and number of rows of matrix H -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A (A') -C and number of columns of matrix H -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - DOUBLE PRECISION array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IP1 - INTEGER array of dimension (M) -C On exit IP1 specifies the row permutation of matrix AN -C (IP1(1) == 0 if no permutation). -C -C DESCRN - CHARACTER*1 array of DIMENSION (9) -C On exit DESCRN describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C AN - DOUBLE PRECISION array of DIMENSION (LAN) -C On exit AN specifies the values of the output sparse -C matrix. If LAN=0, INT(AN(1)) is the minimum value for LAN -C satisfying DSPDP memory requirements. -C -C IAN1 - INTEGER array of dimension (LIAN1) -C On exit IAN1 holds integer information on output sparse -C matrix. Actual information will depend on data format used. -C If LIAN1=0, INT(IAN1(1)) is the minimum value for LIAN1 -C satisfying DSPDP memory requirements. -C -C IAN2 - INTEGER array of dimension (LIAN2) -C On exit IAN2 holds integer information on output sparse -C matrix. Actual information will depend on data format used. -C If LIAN2=0, INT(IAN2(1)) is the minimum value for LIAN2 -C satisfying DSPDP memory requirements. -C -C INFON - INTEGER array of dimension (10) -C On exit can hold auxiliary information on output matrices -C formats or environment of subsequent calls. -C -C IP2 - INTEGER array of dimension (M) -C On exit IP2 specifies the column permutation of matrix AN -C (IP2(1) == 0 if no permutation). -C -C LAN - INTEGER -C On entry LAN specifies the dimension of AN -C LAN must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C LIAN1 - INTEGER -C On entry LH1 specifies the dimension of IAN1 -C LH1 must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C LIAN2 - INTEGER -C On entry LIAN2 specifies the dimension of IAN2 -C LIAN2 must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPDP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK must satisfy memory necessary for the data conversion. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 error -C -C - SUBROUTINE DCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, - * DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, - * WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C -C .. Scalar Arguments .. - INTEGER M, N, LAN, LIAN1, LIAN2, LWORK, IERROR - CHARACTER TRANS, UNITD -C .. Array Arguments .. - real(psb_dpk_) A(*), AN(*), D(*), WORK(LWORK) - INTEGER IA1(*), IA2(*), IAN1(*), IAN2(*), IP1(*), IP2(*), - * INFOA(*), INFON(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER I, J, ERR_ACT - LOGICAL EXIT -c .. Local Arrays .. - character idescra*11 - CHARACTER*20 NAME - INTEGER INT_VAL(5) - -C .. Intrinsic Functions .. - INTRINSIC DBLE, DSQRT - -C .. Executable Statements .. -C - EXIT=.FALSE. - NAME = 'DCRCR' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) -C -C Check for argument errors -C - idescra=psb_toupper(descra) - IF (((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. - & idescra(1:1) .EQ. 'A') .AND. (psb_toupper(unitd) .NE. 'B')) - + .OR. - & (.NOT.((idescra(3:3).EQ.'N').OR.(idescra(3:3).EQ.'L').OR. - + (idescra(3:3).EQ.'U'))) - + .OR. - + psb_toupper(TRANS).NE.'N') THEN - IERROR = 20 - ENDIF - IF(LAN.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - AN(1) = DBLE(IA2(M+1)-1) - ELSE - IERROR = 21 - ENDIF - ENDIF - IF(LIAN1.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN1(1) = IA2(M+1)-1 - ELSE - IERROR = 22 - ENDIF - ENDIF - IF(LIAN2.LT.(M+1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN2(1) = M+1 - ELSE - IERROR = 23 - ENDIF - ENDIF - IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. - & idescra(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .EQ. 'B')) - + THEN - IF (LWORK.LT.M) THEN - IF (LWORK.LE.0) THEN - EXIT=.TRUE. - ELSE - IERROR = 25 - ENDIF - WORK(1) = DBLE(M) - ENDIF - ELSE - IF (LWORK.LT.0) THEN - WORK(1) = 0.D0 - ENDIF - ENDIF -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (EXIT) goto 9998 -C -C Set DESCRN, IP1, IP2 -C - DESCRN(1:3) = idescra(1:3) - - IP1(1)=0 - IP2(1)=0 -C -C Compute output matrix -C - DO 20 I = 1, M+1 - IAN2(I) = IA2(I) - 20 CONTINUE - IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. - & idescra(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .EQ. 'B')) - + THEN - DO 30 I = 1, M - WORK(I) = DSQRT(D(I)) - 30 CONTINUE - DO 40 I = 1, M - DO 50 J = IA2(I), IA2(I+1)-1 - AN(J) = WORK(I) * A(J) * WORK(IA1(J)) - IAN1(J) = IA1(J) - 50 CONTINUE - 40 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'L') THEN - DO 60 I = 1, M - DO 70 J = IA2(I), IA2(I+1)-1 - AN(J) = D(I) * A(J) - IAN1(J) = IA1(J) - 70 CONTINUE - 60 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'R') THEN - DO 80 I = 1, M - DO 90 J = IA2(I), IA2(I+1)-1 - AN(J) = A(J) * D(IA1(J)) - IAN1(J) = IA1(J) - 90 CONTINUE - 80 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'U') THEN - DO 100 J = 1, IA2(M+1)-1 - AN(J) = A(J) - IAN1(J) = IA1(J) - 100 CONTINUE - ENDIF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - - diff --git a/base/serial/dp/dcrjd.f b/base/serial/dp/dcrjd.f deleted file mode 100644 index a4ab9076c..000000000 --- a/base/serial/dp/dcrjd.f +++ /dev/null @@ -1,315 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DCRJD(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, - * LIAN2,AUX,LAUX,SIZE_REQ,IERROR) -C -C Purpose -C ======= -C -C DCRJD converts a CSR matrix into a Jagged Diagonal. -C -C -C Notes -C ===== -C -C Parameters -C ========== -C -C TRANS Whether the transpose should be converted. -C -C M,N Size of input matrix A -C -C UNITD Scaling by diagonal D: 'U'nit, 'L'eft, 'R'ight -C D(*) -C -C DESCRA Input matrix A. -C AR,IA1, -C IA2,INFO -C -C DESCRN Output matrix in JAD format -C ARN,IAN1 -C IAN2,INFON, IP1, IP2 -C - use psb_const_mod - use psb_spmat_type - use psb_string_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, N, - * SIZE_REQ, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - real(psb_dpk_) AR(*), ARN(LARN), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(LIAN1), - + IAN2(LIAN2), INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER IOFF, ISTROW, NJA, NZ, PIA, - + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT - LOGICAL SCALE - CHARACTER UPLO - INTEGER MAX_NNZERO -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5), IERRV(5) - -C .. External Subroutines .. - EXTERNAL DVTFG - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - NAME = 'DCRJD\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (LAUX.LT.4) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = 4 - INT_VAL(3) = LAUX - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IF (psb_toupper(TRANS).EQ.'N') THEN -C - NJA = 3*M - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - IOFF = 5 -C -C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX -C - PNG = IOFF - PIA = PNG + 1 - PJA = PIA + 3*(M+2) - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN - -C -C CHECK ON DIMENSION OF IAN2 AND AUX -C - MAX_NG = M/PSB_MINJDROWS_+1 - - IF ((PIA+3*(MAX_NG+1).GT.LIAN2).OR.(M+1 .GT. LAUX)) THEN -C ... If I haven't sufficent memory to compute NG in IAN2 ... - IF (M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1.GT.LAUX) THEN -C ... If I haven't sufficent memory to compute NG in AUX ... - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1 - INT_VAL(3) = LAUX - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE -C ... I have sufficent memory to compute NG in AUX ... - CALL DGBLOCK(M,IA2,IP1,AUX(M+2),NG, AUX, LAUX*2) - CALL CHECK_DIM(M,N,AUX(M+2),NG,IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - IF (IERRV(1).NE.0) THEN - SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) - - GOTO 9998 - ENDIF - ENDIF - END IF - - NZ = IA2(M+1) - 1 -C -C ... Initialize Permutation Matrix ... -C - DO 10 K = 1, M - IP1(K) = K - 10 CONTINUE - - IP2(1) = 0 - - CALL DGBLOCK(M,IA2,IP1,IAN2(PIA),IAN2(PNG), AUX, LAUX*2) - - PJA = PIA + 3*(IAN2(PNG)+1) -C -C CHECK FOR ARRAY DIMENSIONS -C - CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - IF (IERRV(1) .NE.0) THEN - SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) - GOTO 9998 - ENDIF - - LJA = LIAN2-PJA - CALL DGINDEX(M,IAN2(PNG),AR,IA1,IA2,info, - + ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON, - + LARN,LIAN1, LJA,IP1, - + AUX, LAUX*2, SIZE_REQ,IERROR) - - IF (IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - DESCRN(1:1) = 'G' - DESCRN(2:2) = 'U' - DESCRN(3:3) = 'N' - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN -C - ISTROW = 1 - NZ = 2*(IA2(M+1)-1) - M -C -C CHECK ON DIMENSION OF IAN1 AND ARN -C - IF (NZ .GT. LIAN1) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NZ - INT_VAL(3) = LAUX - LIAN1 = NZ - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (NZ .GT. LARN) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NZ - INT_VAL(3) = LAUX - LIAN1 = NZ - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - -c$$$ CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$ * AUX(IWORK1)) -c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), -c$$$ * AUX(IWORK2),NJA,IER,SCALE) -C - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T') THEN -C -C Only unit diagonal so far for triangular matrices. -C - - - IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN - IERROR=3022 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - UPLO = DESCRA(2:2) - NZ = IA2(M+1) - 1 -C -C ...Compute levels... -C Each level correspond to a block -C IAN1 is used as a work area - - CALL DVTFG(UPLO,M,IA1,IA2,IAN2(PNG),IP2,IP1,IAN1, - + AUX,AUX(M+1),AUX(2*(M+1))) - -C Generate IA(1,*) - DO K = 1, IAN2(PNG)+1 - IAN2(PIA+3*(K-1)) = IAN1(K) - ENDDO - - CALL GEN_BLOCK(M,IAN2(PNG),IAN2(PIA),AUX) - - PJA = PIA + 3*(IAN2(PNG)+1) - -C -C CHECK FOR ARRAY DIMENSIONS -C - - CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - - IF (IERRV(1).NE.0) THEN - size_req = max(ierrv(2),ierrv(3),ierrv(4)) -c$$$ write(0,*) "error 2",ierrv(1) - GOTO 9998 - endif - LJA = LIAN2-PJA - - CALL DGIND_TRI(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), - + IAN2(PJA),LARN,LIAN1,LJA,IP1,AUX, LAUX*2, IERROR) - - IF (IERROR.NE.0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - DESCRN(1:1) = 'T' - DESCRN(2:3) = psb_toupper(DESCRA(2:3)) - - END IF -C -C SET THE OUTPUT PARAMETER -C - IAN2(1) = PNG - IAN2(2) = PIA - IAN2(3) = PJA - LARN = NZ - LIAN1 = NZ - LIAN2 = 3*M + 10 - LAUX2 = 4*M + 2 -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO BE DONE -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/dcsrp1.f b/base/serial/dp/dcsrp1.f deleted file mode 100644 index 1dfee4564..000000000 --- a/base/serial/dp/dcsrp1.f +++ /dev/null @@ -1,196 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Purpose -C ======= -C -C Performing column permutation of a sparse matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will use -C matrix P or the transpose of P for the permutation as follows: -C TRANS = 'N' -> permute with matrix P -C TRANS = 'T' or 'C' -> permute the transpose of P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C DESCRA - CHARACTER*5 array of DIMENSION (10) -C On entry DESCRA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C On exit contain integer information on permuted matrix. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C On exit contain integer information on permuted matrix. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the column permutation of matrix A -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPRP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C Work area. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK. -C LWORK must be greater than zero. -C On exit LWORK is the maximum between the initial value and -C the minimum value satisfying DSPRP memory requirements. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR = 4 error on dimension of vector WORK -C IERROR = 32 unknown flag TRANS -C IERROR = 64 LWORK <= 0 -C IERROR = 128 this data structure not yet considered -C -C Notes -C ===== -C It is not possible to call this subroutine with LWORK=0 to get -C the minimal value for LWORK. This functionality needs a better -C connection with DxxxMM -C -C - SUBROUTINE DCSRP1(TRANS,M,N,DESCRA,JA,IA, - + P,WORK,IWORK,LWORK,IERROR) - use psb_const_mod - use psb_spmat_type - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LWORK,M, N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - real(psb_dpk_) WORK(*) - INTEGER JA(*), IA(*), P(*), IWORK(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, J, ERR_ACT -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) -C .. Intrinsic Functions .. - INTRINSIC DBLE -C -C .. Executable Statements .. -C - NAME = 'DCSRP1\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF(psb_toupper(TRANS).EQ.'N') THEN - DO 30 I=1,M - DO 10 J=IA(I),IA(I+1)-1 - JA(J) = P(JA(J)) - 10 CONTINUE - 30 CONTINUE - WORK(1) = 0.D0 - ELSE IF(psb_toupper(TRANS).EQ.'T') THEN -C -C LWORK refers here to INTEGER IWORK (alias for WORK) -C - IF(LWORK.LT.M) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = M - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Transpose permutation matrix -C - DO 20 I=1,N - IWORK(P(I)) = I - 20 CONTINUE -C -C Permute columns -C - DO 50 I=1,M - DO 40 J=IA(I),IA(I+1)-1 - JA(J) = IWORK(JA(J)) - 40 CONTINUE - 50 CONTINUE -C -C WORK(1) refers here to a value for a DOUBLE PRECISION WORK -C - WORK(1) = DBLE((M+1)/PSB_DBLEINT_) - ENDIF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/dcsrrp.f b/base/serial/dp/dcsrrp.f deleted file mode 100644 index 256a98919..000000000 --- a/base/serial/dp/dcsrrp.f +++ /dev/null @@ -1,174 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Purpose -C ======= -C -C Performing column permutation of a sparse matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will use -C matrix P or the transpose of P for the permutation as follows: -C TRANS = 'N' -> permute with matrix P -C TRANS = 'T' or 'C' -> permute the transpose of P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C DESCRA - CHARACTER*5 array of DIMENSION (10) -C On entry DESCRA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the column permutation of matrix A -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPRP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C Work area. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK. -C LWORK must be greater than zero. -C On exit LWORK is the maximum between the initial value and -C the minimum value satisfying DSPRP memory requirements. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR = 4 error on dimension of vector WORK -C IERROR = 32 unknown flag TRANS -C IERROR = 64 LWORK <= 0 -C IERROR = 128 this data structure not yet considered -C -C Notes -C ===== -C It is not possible to call this subroutine with LWORK=0 to get -C the minimal value for LWORK. This functionality needs a better -C connection with DxxxMM -C -C - SUBROUTINE DCSRRP(TRANS,M,N,DESCRA,JA,IA, - + P,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LWORK, M, N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - real(psb_dpk_) WORK(*) - INTEGER JA(*), IA(*), P(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER ERR_ACT -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) -C .. External Subroutines .. - EXTERNAL XERBLA -C -C .. Executable Statements .. -C - NAME = 'DCSRRP\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (psb_toupper(DESCRA(1:1)).EQ.'S' .OR. - + psb_toupper(DESCRA(1:1)).EQ.'T') THEN - IERROR=3023 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - endif - CALL DCSRP1(TRANS,M,N,DESCRA,JA,IA,P,WORK,WORK,LWORK*2,IERROR) - IF(IERROR.NE.0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/dgblock.f b/base/serial/dp/dgblock.f deleted file mode 100644 index 9afcbbfd5..000000000 --- a/base/serial/dp/dgblock.f +++ /dev/null @@ -1,94 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DGBLOCK(M,IA2,IPERM,IA,N_BLOCK,WORK,LWORK) - IMPLICIT NONE - -C ...Scalar arguments... - - INTEGER M, N_BLOCK, LWORK - -C ...Array arguments... - - INTEGER IA2(*), IPERM(*), IA(3,*), WORK(*) - -C ...Local scalars... - - INTEGER I, SWAP, KK, LP, IRET -C Compute number of nnzero elements per row - - IPERM(1) = 0 - - DO I = 1, M - WORK(I) = - IA2(I+1) + IA2(I) - ENDDO - -C Sorting Array work -C ........................ - - CALL MSORT_UP(M,WORK,WORK(M+1),IRET) - IF (IRET.EQ.0) THEN -C Construct IPERM Vector - LP = WORK(M+1) - - DO I = 1, M - IPERM(LP) = I - LP = WORK(M+1+LP) - ENDDO - - LP = WORK(M+1) - KK = 1 - DO WHILE (.NOT.((LP.EQ.0).OR.(KK.GT.M))) - DO WHILE (LP.LT.KK) - LP = WORK(M+1+LP) - ENDDO -C Swap values of array work - SWAP = WORK(KK) - WORK(KK) = WORK(LP) - WORK(LP) = SWAP - -C Swap values of index array work(m+1) - SWAP = WORK(M+1+LP) - WORK(M+1+LP) = WORK(M+1+KK) - WORK(M+1+KK) = LP - - LP = SWAP - KK = KK+1 - ENDDO - - ENDIF -C Partitioning Matrix in blocks of rows - CALL PARTITION(M, WORK, IA, N_BLOCK) - - END - - - diff --git a/base/serial/dp/dgind_tri.f b/base/serial/dp/dgind_tri.f deleted file mode 100644 index af5f1652f..000000000 --- a/base/serial/dp/dgind_tri.f +++ /dev/null @@ -1,237 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, - + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) - - use psb_const_mod - IMPLICIT NONE - -C ... Scalar arguments ... - - INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, IERROR - -C ... Array arguments ... - - real(psb_dpk_) A(*), ARN(*), WORK(*) - INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(M), JA(*) - -C .... Local scalars ... - INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, - + DIM_BLOCK, LIMIT, ERR_ACT - LOGICAL CSR -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'DGIND_TRI\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - POINT_AR = 1 - POINT_JA = 0 - IERROR = 0 - - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C .... Invert Permutation Matrix... - IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO - ENDIF - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - ARN(POINT_AR) = 0.D0 -C -C The following statement assumes that we never get here with POINT_AR=1 -C - KA (POINT_AR) = KA(POINT_AR-1) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IPERM(IA1(IA2(ROW)+COL-1)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - 998 CONTINUE - - ENDIF - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IPERM(IA1(J)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - IA(2,N_BLOCKS+1) = POINT_JA - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/dgindex.f b/base/serial/dp/dgindex.f deleted file mode 100644 index 70ff065bb..000000000 --- a/base/serial/dp/dgindex.f +++ /dev/null @@ -1,463 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON, - + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) - - use psb_const_mod - use psb_spmat_type - IMPLICIT NONE - -C ... Scalar arguments ... - INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, - + SIZE_REQ,IERROR - -C ... Array arguments ... - - real(psb_dpk_) A(*), ARN(LARN) - INTEGER IA1(*), IA2(*), KA(LKA), - + IA(3,*), IPERM(*), JA(LJA), WORK(*),INFON(*), infoa(*) - -C .... Local scalars ... - INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1, - + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG, - + ERR_ACT, ix, regen_flag - LOGICAL CSR -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'DGINDEX\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - POINT_AR = 1 - POINT_JA = 0 - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - - - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - NNZ = IA2(M + 1) - 1 - COUNT = 0 - -C .... Invert Permutation Matrix... - IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO - ENDIF - - size_Req=0 - - IF ( (regen_flag == psb_upd_perm_) - + .AND. (LWORK .GE. (M + NNZ+2))) THEN -C -C Prepare for smart regeneration -C - - IPW = M + 2 - IP1 = (LKA-PSB_IREG_FLGS_-2)/2 - IP2 = IP1+PSB_IREG_FLGS_ - IPC = IP2 + NNZ + 1 - KA(IP1 + PSB_IPC_) = IPC - KA(IP1+PSB_IP2_) = IP2 - INFON(PSB_UPD_PNT_) = IP1 - KA(IP1+PSB_IFLAG_) = CHECK_FLAG - KA(IP1+PSB_NNZT_) = NNZ - KA(IP1+PSB_NNZ_) = 0 - KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG - - if (infoa(psb_upd_pnt_) > 0) then - I = infoa(psb_upd_pnt_) - IPX = IA2(I+PSB_IP2_) -C Invert permutation for smart regeneration - - DO I = 1, NNZ - WORK(IPW + IA2(IPX + I -1) - 1) = I - ENDDO - else - ! No permutation available before, set identity. - DO I = 1, NNZ - WORK(IPW + I - 1) = I - ENDDO - endif -C Construct JAD matrix... - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) -c$$$ write(0,*) 'DGINDEX: BLOCK LOOP ',block,n_blocks,dim_block - if (dim_block .gt. PSB_MAXJDROWS_) then - write(0,*) 'Wrong value for dim_block',block, - + IA(1,BLOCK+1),IA(1,BLOCK) - return - endif - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - - COUNT = COUNT + 1 - ARN(POINT_AR) = 0.D0 - KA(POINT_AR) = KA(POINT_AR-1) - IF(POINT_AR.LT.IP1) THEN - KA(IPC + COUNT -1) = POINT_AR - ENDIF -C -C The following statement assumes that we never get here with POINT_AR=1 -C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA(POINT_AR) = IA1(IA2(ROW)+COL-1) - IF(POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + - + IA2(ROW) +COL -1-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF(IERROR.EQ.0) THEN - JA(POINT_JA+COL) = POINT_AR - ENDIF - COL = COL+1 - ENDDO - - ENDIF - 998 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - IF (POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + J-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - IA(2,N_BLOCKS+1) = POINT_JA - KA(IP1 + PSB_ZERO_) = COUNT - - IF (POINT_AR.GE.IP1) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF - - ELSE -c$$$ c write(*,*)'inizio a ciclare sui blocchi' - IP1 = LKA - PSB_ZERO_ - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 999 - ELSE - COUNT= COUNT+1 - ARN(POINT_AR) = 0.D0 - KA (POINT_AR) = KA(POINT_AR-1) -C -C The following statement assumes that we never get here with POINT_AR=1 -C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IA1(IA2(ROW)+COL-1) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 999 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - - ENDIF - 999 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - - - IA(2,N_BLOCKS+1) = POINT_JA - - IF (POINT_AR.GE.lka) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF - ENDIF - - infon(1)=point_ar-1 - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/djadrp.f b/base/serial/dp/djadrp.f deleted file mode 100644 index 885a792dc..000000000 --- a/base/serial/dp/djadrp.f +++ /dev/null @@ -1,173 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Purpose -C ======= -C -C Performing column permutation of a sparse matrix in JAD format. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will use -C matrix P or the transpose of P for the permutation as follows: -C TRANS = 'N' -> permute with matrix P -C TRANS = 'T' or 'C' -> permute the transpose of P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C DESCRA - CHARACTER*5 array of DIMENSION (10) -C On entry DESCRA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C On exit contain integer information on permuted matrix. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C On exit contain integer information on permuted matrix. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the column permutation of matrix A -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPRP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C Work area. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK. -C LWORK must be greater than zero. -C On exit LWORK is the maximum between the initial value and -C the minimum value satisfying DSPRP memory requirements. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR = 4 error on dimension of vector WORK -C IERROR = 32 unknown flag TRANS -C IERROR = 64 LWORK <= 0 -C IERROR = 128 this data structure not yet considered -C -C Notes -C ===== -C It is not possible to call this subroutine with LWORK=0 to get -C the minimal value for LWORK. This functionality needs a better -C connection with DxxxMM -C -C - SUBROUTINE DJADRP(TRANS,M,N,DESCRA,JA,IA, - + P,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LWORK, M, N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - real(psb_dpk_) WORK(*) - INTEGER JA(*), IA(*), P(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER PIA, PJA, PNG, IOFF, ERR_ACT -C .. Intrinsic Functions .. - INTRINSIC DBLE -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) -C -C .. Executable Statements .. -C - NAME = 'DJADRP\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IOFF = 5 -C -C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX -C - PNG = IOFF - PIA = PNG + 1 - PJA = PIA + 3*(IA(PNG)+1) - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN - CALL DJADRP1(TRANS,M,N,DESCRA,IA(PNG), - + JA,IA(PIA),IA(PJA),P,WORK,LWORK*2) - ELSE - IERROR=3024 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/djadrp1.f b/base/serial/dp/djadrp1.f deleted file mode 100644 index b0934a933..000000000 --- a/base/serial/dp/djadrp1.f +++ /dev/null @@ -1,200 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Purpose -C ======= -C -C Performing column permutation of a sparse matrix in JAD format. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will use -C matrix P or the transpose of P for the permutation as follows: -C TRANS = 'N' -> permute with matrix P -C TRANS = 'T' or 'C' -> permute the transpose of P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C DESCRA - CHARACTER*5 array of DIMENSION (10) -C On entry DESCRA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C On exit contain integer information on permuted matrix. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C On exit contain integer information on permuted matrix. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the column permutation of matrix A -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C IWORK - INTEGER array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPRP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR = 4 error on dimension of vector WORK -C IERROR = 32 unknown flag TRANS -C IERROR = 64 LWORK <= 0 -C IERROR = 128 this data structure not yet considered -C -C Notes -C ===== -C It is not possible to call this subroutine with LWORK=0 to get -C the minimal value for LWORK. This functionality needs a better -C connection with DxxxMM -C -C - SUBROUTINE DJADRP1(TRANS,M,N,DESCRA,NG,KA,IA,JA, - + P,IWORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LWORK,M, N, NG, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER KA(*), JA(*), IA(3,*), P(*), IWORK(LWORK) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER I, K, IPG, ERR_ACT -C .. Intrinsic Functions .. - INTRINSIC DBLE -C .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) -C -C .. Executable Statements .. -C - NAME = 'DJADRP\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF(psb_toupper(TRANS).EQ.'N') THEN - DO IPG = 1, NG - DO K = IA(2,IPG), IA(3,IPG)-1 - DO I = JA(K), JA(K+1) - 1 - KA(I) = P(KA(I)) - ENDDO - ENDDO -C Permute CSR - - DO K = IA(3,IPG), IA(2,IPG+1)-1 - DO I = JA(K), JA(K+1) - 1 - KA(I) = P(KA(I)) - ENDDO - ENDDO - ENDDO - - IWORK(1) = 0 - ELSE IF(psb_toupper(TRANS).EQ.'T') THEN -C -C LWORK refers here to INTEGER IWORK (alias for WORK) -C - IF(LWORK.LT.M) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = M - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Transpose permutation matrix -C - DO 20 I=1,N - IWORK(P(I)) = I - 20 CONTINUE -C -C Permute columns -C - DO IPG = 1, NG - DO K = IA(2,IPG), IA(3,IPG)-1 - DO I = JA(K), JA(K+1) - 1 - KA(I) = IWORK(KA(I)) - ENDDO - ENDDO -C Permute CSR - - DO K = IA(3,IPG), IA(2,IPG+1)-1 - DO I = JA(K), JA(K+1) - 1 - KA(I) = IWORK(KA(I)) - ENDDO - ENDDO - ENDDO -C -C WORK(1) refers here to a value for a DOUBLE PRECISION WORK -C - IWORK(1) = M+1 - ENDIF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/djdco.f b/base/serial/dp/djdco.f deleted file mode 100644 index 912471de0..000000000 --- a/base/serial/dp/djdco.f +++ /dev/null @@ -1,91 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DJDCO(TRANS,M,N,DESCRA,AR,IA1,IA2,IPERM,INFO, - * IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N, - * LIA2N,AUX,LAUX,IERROR) - use psb_const_mod - use psb_error_mod - IMPLICIT NONE -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LIA1N, LIA2N, M, N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - real(psb_dpk_) AR(*), ARN(*) - INTEGER AUX(0:LAUX-1),IPERM(*) - INTEGER IA1(*), IA2(*), INFO(*), IA1N(*), - * IA2N(*), INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER PIA, PJA, PNG, ERR_ACT - integer :: debug_level, debug_unit -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'DJDCO' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - PNG = IA2(1) - PIA = IA2(2) - PJA = IA2(3) - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': On entry NNZ LAUX ', - + info(1),laux,larn,lia1n,lia2n - - CALL DJDCOX(TRANS,M,N,DESCRA,AR,IA2(PIA),IA2(PJA), - * IA1,IA2(PNG),IPERM, INFO, IP1,DESCRN,ARN,IA1N,IA2N,INFON, - * IP2,LARN,LIA1N, LIA2N,AUX,LAUX,IERROR) - IF(IERROR.NE.0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/djdcox.f b/base/serial/dp/djdcox.f deleted file mode 100755 index 7b688ba6c..000000000 --- a/base/serial/dp/djdcox.f +++ /dev/null @@ -1,210 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - - -C Covert matrix from JAD format to COO Format -C - SUBROUTINE DJDCOX(TRANS,M,N,DESCRA,AR,IA,JA,KA,NG,IPERM,INFO, - * IP1,DESCRN,ARN,IA1N,IA2N,INFON,IP2,LARN,LIA1N, - * LIA2N,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_string_mod - use psb_error_mod - use psb_ip_reord_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER NG, LARN, LAUX, LIA1N, LIA2N, M, N, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - real(psb_dpk_) AR(*), ARN(*) - INTEGER AUX(0:LAUX/2-1),IPERM(*) - INTEGER IA(3,*), JA(*), KA(*), INFO(*), IA1N(*), - * IA2N(*), INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER IPX, IPG, NNZ, K, ROW, - * I, J, NZL, IRET, ERR_ACT - LOGICAL SCALE - integer :: debug_level, debug_unit -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - -C -C .. Executable Statements .. -C - NAME = 'DJDCOX' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF (psb_toupper(TRANS).EQ.'N') THEN -C SCALE = (UNITD.EQ.'L') ! meaningless - IP1(1) = 0 - IP2(1) = 0 - - IF (IPERM(1).NE.0) THEN - DO I = 1, M - AUX(IPERM(I)) = I - ENDDO - ENDIF - - NNZ = JA(IA(2,NG+1)-1 +1)-1 - - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': On entry NNZ LAUX ', - + nnz,laux,larn,lia1n,lia2n - endif - IF (LAUX.LT.NNZ+2) THEN - IERROR = 60 - INT_VAL(1) = 23 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LIA1N.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LIA2N.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 21 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ENDIF - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN - - DO 200 IPG = 1, NG - DO 50 K = IA(2,IPG), IA(3,IPG)-1 - IPX = IA(1,IPG) - DO 40 I = JA(K), JA(K+1) - 1 - ARN(I) = AR(I) - IA1N(I) = AUX(IPX) - IA2N(I) = KA(I) - IPX = IPX + 1 - 40 CONTINUE - 50 CONTINUE - - IPX = IA(1,IPG) - DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 - DO 60 I = JA(K), JA(K+1) - 1 - ARN(I) = AR(I) - IA1N(I) = AUX(IPX) - IA2N(I) = KA(I) - 60 CONTINUE - IPX = IPX + 1 - 70 CONTINUE - 200 CONTINUE - - - -C .... Order with key IA1N.... - CALL MSORT_UP(NNZ,IA1N,AUX,IRET) - if (iret == 0) call psb_ip_reord(nnz,arn, - + ia1n,ia2n,aux) - -C .... Order with key IA2N ... - I = 1 - J = I - DO WHILE (I.LE.NNZ) - DO WHILE ((IA1N(J).EQ.IA1N(I)).AND. - + (J.LE.NNZ)) - J = J+1 - ENDDO - NZL = J - I - CALL MSORT_UP(NZL,IA2N(I),AUX,IRET) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1),aux) - - I = J - ENDDO - INFON(1)=nnz - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - -c$$$ ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'U') THEN -c$$$ -c$$$ ELSE IF (DESCRA(1:1).EQ.'T' .AND. DESCRA(2:2).EQ.'L') THEN - else - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO DO -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - - - - - - - - - diff --git a/base/serial/dp/dvtfg.f b/base/serial/dp/dvtfg.f deleted file mode 100644 index d2250b3c4..000000000 --- a/base/serial/dp/dvtfg.f +++ /dev/null @@ -1,204 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C -C Compute level numbers for the triangular matrix. -C - SUBROUTINE DVTFG (UPLO,M,JA,IA,NG,IPA,IPAT,KLEN,IWORK1,IWORK2, - * IWORK3) - use psb_const_mod - use psb_string_mod - use psb_error_mod - implicit none -C .. Scalar Arguments .. - INTEGER M, NG - CHARACTER UPLO -C .. Array Arguments .. - INTEGER IA(*), IPA(*), IPAT(*), IWORK3(*), JA(*), - * KLEN(*), IWORK2(*), IWORK1(*) -C .. Local Scalars .. - INTEGER I, J, L, L0, L1, LEV, NP, iret -C .. Intrinsic Functions .. - INTRINSIC MAX - integer :: debug_level, debug_unit - character(len=20) :: name='DVTFG' -C .. Executable Statements .. -C - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - NG = 0 -C -C CHECK ON THE NUMBERS OF THE ELEMENTS OF THE MATRIX -C - IF ((IA(M+1)-1).EQ.0) THEN -C -C THE MATRIX HASN'T ELEMENTS -C THE OUTPUT PERMUTATIONS ARE POSED TO THE IDENTITY MATRIX -C - DO 20 I = 1, M - IPA(I) = I - IPAT(I) = I - KLEN(I) = 0 - 20 CONTINUE - ELSE -C -C COMPUTE LEVEL NUMBER FOR EACH ROWS -C -C IWORK1: AUXILIARY VECTOR WHICH CONTAINS -C LEVEL NUMBERS OF EACH ROW -C - DO 40 I = 1, M - IWORK1(I) = 0 - IWORK3(I) = 0 - 40 CONTINUE - IF (psb_toupper(UPLO).EQ.'L') THEN -C -C LOWER TRIANGULAR SPARSE MATRIX -C - DO 80 I = 1, M - IWORK1(I) = 1 - DO 60 J = IA(I), IA(I+1) - 1 - IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1) - 60 CONTINUE - 80 CONTINUE - ELSE IF (psb_toupper(UPLO).EQ.'U') THEN -C -C UPPER TRIANGULAR SPARSE MATRIX -C - DO 120 I = M, 1, -1 - IWORK1(I) = 1 - DO 100 J = IA(I), IA(I+1) - 1 - IWORK1(I) = MAX(IWORK1(I),IWORK1(JA(J))+1) - 100 CONTINUE - 120 CONTINUE - END IF -C -C COUNT NUMBER OF ROWS IN EACH EQUIVALENCE GROUPS -C -C NOTE: GROUP = SET OF ROWS HAVING THE SAME LEVEL NUMBER -C -C IWORK3: AUXILIARY VECTOR WHICH CONTAINS -C THE NUMBER OF ROWS FOR EACH GROUPS -C - DO 140 I = 1, M - IWORK3(IWORK1(I)) = IWORK3(IWORK1(I)) + 1 - 140 CONTINUE -C -C SET UP IWORK2: -C IWORK2(I) POINTS TO THE BEGINNING OF I-TH GROUP -C - IWORK2(1) = 1 - DO 160 I = 2, M + 1 - IWORK2(I) = IWORK3(I-1) + IWORK2(I-1) - IF (IWORK2(I).EQ.M+1) THEN - NG = I - 1 - GO TO 180 - END IF - 160 CONTINUE - 180 CONTINUE -C -C NG : TOTAL NUMBER OF LEVELS -C IWORK3: VECTOR CONTAINING THE NUMBER OF THE ROWS SORTED BY -C EQUIVALENCE GROUPS. -C - DO 200 I = 1, M - IWORK3(IWORK2(IWORK1(I))) = I - IWORK2(IWORK1(I)) = IWORK2(IWORK1(I)) + 1 - 200 CONTINUE -C -C REGENERATE IWORK2: POINTER INTO IWORK3 FOR EQUIVALENCE GROUPS -C - DO 220 I = NG + 1, 2, -1 - IWORK2(I) = IWORK2(I-1) - 220 CONTINUE - IWORK2(1) = 1 -C -C IWORK1: ROWS LENGTH IN NEW ORDERING -C - DO 240 L = 1, M - IWORK1(L) = IA(IWORK3(L)) - IA(IWORK3(L)+1) - 240 CONTINUE -C -C SORT ROWS BY DECREASING NUMBER OF NONZERO ELEMENTS. -C -C IPA: VECTOR OF NUMBER OF ROWS SORTED BY EQUIVALENCE -C GROUPS AND BY ROW LENGTH -C IPAT: AUXILIARY VECTOR NEED TO THE SORTER ROUTINES -C - L1 = IWORK2(2) - IWORK2(1) - DO 260 L = 1, L1 - IPA(L) = IWORK3(L) - 260 CONTINUE - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Group ',1,':',(ipa(l),l=1,l1) - DO 360 LEV = 2, NG -C -C LOOP ON GROUPS -C L1: LENGTH OF CURRENT GROUP -C L0: POINTER TO IPA TO THE FIRST LOCATIONS RESERVED -C FOR CURRENT GROUP -C - L1 = IWORK2(LEV+1) - IWORK2(LEV) - L0 = IWORK2(LEV) - 1 - CALL MSORT_UP(L1,IWORK1(IWORK2(LEV)),IPAT,IRET) - IF (IRET.EQ.0) THEN - NP = IPAT(1) - DO 280 L = 1, L1 - IPA(L0+L) = IWORK3(L0+NP) - NP = IPAT(1+NP) - 280 CONTINUE - ELSE -C -C VECTOR ALREADY SORTED. NO CHANGE IS NEED -C - DO 320 L = 1, L1 - IPA(L0+L) = IWORK3(L0+L) - 320 CONTINUE - ENDIF - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Group ',lev,':',(ipa(l0+l),l=1,l1) - 360 CONTINUE -C -C IPAT = IPA-1 -C - DO 380 I = 1, M - IPAT(IPA(I)) = I - 380 CONTINUE -C DO 400 I = 1, NG -C KLEN(I) = IWORK2(I+1) - IWORK2(I) - DO 400 I = 1, NG+1 - KLEN(I) = IWORK2(I) - 400 CONTINUE - END IF - RETURN - END diff --git a/base/serial/dp/gen_block.f b/base/serial/dp/gen_block.f deleted file mode 100644 index 84186df76..000000000 --- a/base/serial/dp/gen_block.f +++ /dev/null @@ -1,72 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE GEN_BLOCK(M,NG,IA,AUX) - use psb_const_mod - use psb_serial_mod - IMPLICIT NONE - - INTEGER M, NG - INTEGER IA(3,*), AUX(*) - - INTEGER BLOCK, I, N_ROWS - - N_ROWS = IA(1,2) - IA(1,1) - I = 2 - BLOCK = 2 - AUX(1) = 1 - - DO WHILE(.TRUE.) - IF (N_ROWS.GT.PSB_MAXJDROWS_) THEN - AUX(BLOCK) = AUX(BLOCK-1)+PSB_MAXJDROWS_ - N_ROWS = N_ROWS-PSB_MAXJDROWS_ - BLOCK = BLOCK+1 - ELSE IF (N_ROWS.GT.0) THEN - AUX(BLOCK) = AUX(BLOCK-1)+N_ROWS - N_ROWS = 0 - BLOCK = BLOCK+1 - ELSE IF (I.LE.NG) THEN - N_ROWS = IA(1,I+1) - IA(1,I) - I = I+1 - ELSE - GOTO 998 - ENDIF - ENDDO - 998 CONTINUE - -C ... Copy AUX in IA(1,*) - - NG = BLOCK - 2 - DO I = 1, NG+1 - IA(1,I) = AUX(I) - ENDDO - - END diff --git a/base/serial/dp/partition.f b/base/serial/dp/partition.f deleted file mode 100644 index 98be555e1..000000000 --- a/base/serial/dp/partition.f +++ /dev/null @@ -1,92 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE PARTITION(M, WORK, IA, N_BLOCK) - use psb_const_mod - use psb_serial_mod - IMPLICIT NONE - - -C ...Scalar arguments... - - INTEGER M, N_BLOCK - -C ...Array arguments... - - INTEGER IA(3,*), WORK(*) - -C ...Local scalars... - - INTEGER I, NNZ_ROW, N_ROWS, N_ROWS_EQ, BLOCK - - I = 1 - N_ROWS = 0 - BLOCK = 2 - - WORK(M+1) = 1 - - IA(1,1) = 1 - - DO WHILE(.TRUE.) - IF (N_ROWS.GT.PSB_MAXJDROWS_) THEN - IA(1,BLOCK) = IA(1,BLOCK-1)+PSB_MAXJDROWS_ - N_ROWS = N_ROWS-PSB_MAXJDROWS_ - BLOCK = BLOCK+1 - ELSE IF (N_ROWS.GE.PSB_MINJDROWS_) THEN - IA(1,BLOCK) = IA(1,BLOCK-1)+N_ROWS - N_ROWS = 0 - BLOCK = BLOCK+1 - ELSE IF (I.LE.M) THEN - N_ROWS_EQ = 0 - NNZ_ROW = -WORK(I) - DO WHILE (NNZ_ROW.EQ.-WORK(I)) - N_ROWS_EQ = N_ROWS_EQ+1 - I=I+1 - ENDDO - N_ROWS = N_ROWS + N_ROWS_EQ - ELSE IF (N_ROWS.NE.0) THEN ! (I.GT.M) - IA(1,BLOCK) = IA(1,BLOCK-1)+N_ROWS - BLOCK = BLOCK+1 - GOTO 998 - ELSE - GOTO 998 - ENDIF - ENDDO - 998 CONTINUE - - N_BLOCK = BLOCK - 2 - - if (ia(1,n_block+1)-1 .ne. m) then - write(0,*) 'PARTITION: Something wrong',m, - + n_block,ia(1,n_block+1),ia(1,n_block) - endif - END - diff --git a/base/serial/dp/scoco.f b/base/serial/dp/scoco.f deleted file mode 100644 index 6bfbc1a3c..000000000 --- a/base/serial/dp/scoco.f +++ /dev/null @@ -1,306 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -c covert matrix from COO format to COO format -c - subroutine scoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, - * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, - * lia2n,aux,laux,ierror) - use psb_error_mod - use psb_const_mod - use psb_spmat_type - use psb_string_mod - use psb_ip_reord_mod - implicit none - -c .. scalar arguments .. - integer larn, laux, lia1n, lia2n, - + m, n, ierror - character trans,unitd -c .. array arguments .. - real(psb_spk_) ar(*), arn(*), d(*) - integer aux(0:laux-1) - integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*), - * infon(*), p1(*), p2(*) - character descra*11, descrn*11 -c .. local scalars .. - integer ipx, ip1, ip2, check_flag, err_act - integer nnz, k, i, j, nzl, iret - integer elem_in, elem_out - logical scale - integer max_nnzero - integer :: debug_level, debug_unit -c .. local arrays .. - character*20 name - integer int_val(5) -c -c ...common variables... -c this flag describe the action to do - -c .. external subroutines .. - external max_nnzero -c .. executable statements .. -c - - name = 'scoco' - ierror = 0 - call fcpsb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - - if (psb_toupper(trans).eq.'N') then - scale = (psb_toupper(unitd).eq.'L') ! meaningless - p1(1) = 0 - p2(1) = 0 - - call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror) - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': on entry nnz laux ', - + nnz,laux,larn,lia1n,lia2n - endif - if (laux.lt.nnz+2) then - ierror = 60 - int_val(1) = 22 - int_val(2) = nnz+2 - int_val(3) = laux - else if (larn.lt.nnz) then - ierror = 60 - int_val(1) = 18 - int_val(2) = nnz+2 - int_val(3) = laux - else if (lia1n.lt.nnz) then - ierror = 60 - int_val(1) = 19 - int_val(2) = nnz+2 - int_val(3) = laux - else if (lia2n.lt.m+1) then - ierror = 60 - int_val(1) = 20 - int_val(2) = nnz+2 - int_val(3) = laux - endif - -c -c error handling -c - if(ierror.ne.0) then - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - end if - - if (psb_toupper(descra(1:1)).eq.'G') then -c -c sort COO data structure -c - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': first sort',nnz - do k=1, nnz - arn(k) = ar(k) - ia1n(k) = ia1(k) - ia2n(k) = ia2(k) - enddo - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': second sort' - - if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1)) - + .and.(laux.ge.2*(2+nnz))) then -c -c prepare for smart regeneration -c - ipx = nnz+3 - do i=1, nnz - aux(ipx+i-1) = i - enddo - ip1 = nnz+2 - infon(psb_upd_pnt_) = ip1 - ip2 = ip1+psb_ireg_flgs_ - ia2n(ip1+psb_ip2_) = ip2 - ia2n(ip1+psb_iflag_) = check_flag - ia2n(ip1+psb_nnzt_) = nnz - ia2n(ip1+psb_nnz_) = 0 - ia2n(ip1+psb_ichk_) = nnz+check_flag - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': build check :',ia2n(ip1+psb_nnzt_) - -c .... order with key ia1n ... - call msort_up(nnz,ia1n,aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn, - + ia1n,ia2n,aux(ipx:),aux) -c .... order with key ia2n ... - - i = 1 - j = i - do while (i.le.nnz) - do while ((ia1n(j).eq.ia1n(i)).and. - + (j.le.nnz)) - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ia2n(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1), - + aux(ipx+i-1:ipx+i+nzl-1),aux) - i = j - enddo - - ia2n(ip2+aux(ipx+1-1)-1) = 1 - -c ... construct final COO representation... - elem_out = 1 -c ... insert remaining element ... - do elem_in = 2, nnz - if ((ia1n(elem_in).eq.ia1n(elem_out)).and. - + (ia2n(elem_in).eq.ia2n(elem_out))) then - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the first duplicated element ... - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_out) = arn(elem_out) + arn(elem_in) - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - end if - else - elem_out = elem_out + 1 - arn(elem_out) = arn(elem_in) - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - ia1n(elem_out) = ia1n(elem_in) - ia2n(elem_out) = ia2n(elem_in) - endif - enddo - - else - -c .... order with key ia1n ... - call msort_up(nnz,ia1n,aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn, - + ia1n,ia2n,aux) - -c .... order with key ia2n ... - - i = 1 - j = i - do while (i.le.nnz) - do while ((ia1n(j).eq.ia1n(i)).and. - + (j.le.nnz)) - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ia2n(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1),aux) - i = j - enddo -c ... construct final COO representation... - elem_out = 1 -c ... insert remaining element ... - do elem_in = 2, nnz - if ((ia1n(elem_in).eq.ia1n(elem_out)).and. - + (ia2n(elem_in).eq.ia2n(elem_out))) then - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the first duplicated element ... - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_out) = arn(elem_out) + arn(elem_in) - end if - else - elem_out = elem_out + 1 - arn(elem_out) = arn(elem_in) - ia1n(elem_out) = ia1n(elem_in) - ia2n(elem_out) = ia2n(elem_in) - endif - enddo - endif - infon(psb_nnz_) = elem_out - infon(psb_srtd_) = psb_isrtdcoo_ - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': done rebuild COO',infon(1) - - else if (psb_toupper(descra(1:1)).eq.'S' .and. - + psb_toupper(descra(2:2)).eq.'U') then - - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - else if (psb_toupper(descra(1:1)).eq.'T' .and. - + psb_toupper(descra(2:2)).eq.'U') then - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - - else if (psb_toupper(descra(1:1)).eq.'T' .and. - + psb_toupper(descra(2:2)).eq.'L') then - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if -c - else if (psb_toupper(trans).ne.'N') then -c -c to do -c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if - - call fcpsb_erractionrestore(err_act) - return - - 9999 continue - call fcpsb_erractionrestore(err_act) - - if ( err_act .ne. 0 ) then - call fcpsb_serror() - return - endif - - return - end diff --git a/base/serial/dp/scocr.f b/base/serial/dp/scocr.f deleted file mode 100644 index f50e78f64..000000000 --- a/base/serial/dp/scocr.f +++ /dev/null @@ -1,524 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Covert matrix from COO format to CSR Format -C Note: this never sets IP1 and P2! -C - SUBROUTINE SCOCR(TRANS,M,N,UNITD,D,DESCRA,AR,JA,IA,INFO, - * P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1, - * LIAN2,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_ip_reord_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LIAN1, LIAN2, M, - + N, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - real(psb_spk_) AR(*), ARN(*), D(*) - INTEGER AUX(0:LAUX-1) - INTEGER JA(*), IA(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), P1(*), P2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - integer nnz, k, row, i, j, nzl, iret - integer ipx, ip1, ip2, check_flag, err_act - integer elem, elem_csr,regen_flag - logical scale - integer max_nnzero - integer, allocatable :: itmp(:) -c .. local arrays .. - character*20 name - integer int_val(5) - integer :: debug_level, debug_unit - -c -C ...Common variables... - -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - - NAME = 'SCOCR' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - - IF (psb_toupper(TRANS).EQ.'N') THEN - - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - P1(1) = 0 - P2(1) = 0 - nnz = info(1) - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': On entry NNZ LAUX ', - + nnz,laux,larn,lian1,lian2 - endif - IF (LAUX.LT.NNZ+2) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ - INT_VAL(3) = LARN - ELSE IF (LIAN1.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN1 - ELSE IF (LIAN2.LT.M+1) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = M+1 - INT_VAL(3) = LIAN2 - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - allocate(itmp(nnz),stat=iret) - if (iret /= 0) then - call fcpsb_errpush(4010,name,int_val) - goto 9999 - end if - - do k=1, nnz - arn(k) = ar(k) - ian1(k) = ja(k) - itmp(k) = ia(k) - enddo - ! Mark as unavailable by default. - infon(psb_upd_pnt_) = 0 - - - IF (psb_toupper(descra(1:1)).EQ.'G') THEN -C -C Sort COO data structure -C - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': First sort',nnz - - if ((regen_flag==psb_upd_perm_).and. - + (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) - + .and.(laux.ge.2*(2+nnz))) then -C -C Prepare for smart regeneration -c - ipx = nnz+3 - do i=1, nnz - aux(ipx+i-1) = i - enddo - ip1 = m+2 - infon(psb_upd_pnt_) = ip1 - ip2 = ip1+psb_ireg_flgs_ - ian2(ip1+psb_ip2_) = ip2 - ian2(ip1+psb_iflag_) = check_flag - ian2(ip1+psb_nnzt_) = nnz - ian2(ip1+psb_nnz_) = 0 - ian2(ip1+psb_ichk_) = nnz+check_flag - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Build check :',ian2(ip1+psb_nnzt_) - -C .... Order with key IA ... - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux(ipx:),aux) - - if (debug_level >= psb_debug_serial_) then - do i=1, nnz-1 - if (itmp(i).gt.itmp(i+1)) then - write(debug_unit,*) trim(name), - + 'Sorting error:',i,itmp(i),itmp(i+1) - endif - enddo - write(debug_unit,*) trim(name), - + 'nnz :',m,nnz,itmp(nnz),ian1(nnz) - endif - -C .... Order with key JA ... - - I = 1 - J = I - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1), - + aux(ipx+i-1:ipx+i+nzl-1),aux) - i = j - enddo - -c ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -c ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem = elem+1 - elem_csr = elem_csr+1 -c ... insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -c ... insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - - else -C .... Order with key IA ... - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - - i = j - enddo - - - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - endif - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': Done Rebuild CSR', - + ian2(m+1),ia(elem) - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - do 20 k = 1, m - p2(k) = k - 20 continue - - else if (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - i = j - enddo - - - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - else if (psb_toupper(descra(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') THEN - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - i = j - enddo - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': Done Rebuild CSR', - + ian2(m+1),ia(elem) - - - end if -c - else if (psb_toupper(TRANS).NE.'N') then -c -c to do -c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if - infon(1)=elem_csr-1 - - call fcpsb_erractionrestore(err_act) - return - - 9999 continue - call fcpsb_erractionrestore(err_act) - - if ( err_act .ne. 0 ) then - call fcpsb_serror() - return - endif - - return - end diff --git a/base/serial/dp/scrco.f b/base/serial/dp/scrco.f deleted file mode 100644 index e42327e9c..000000000 --- a/base/serial/dp/scrco.f +++ /dev/null @@ -1,193 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SCRCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, - * LIAN2,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_spmat_type - use psb_string_mod - use psb_error_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LIAN1, LIAN2, M, N, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - real(psb_spk_) AR(*), ARN(*), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER NNZ, K, ROW, J - INTEGER ELEM, ERR_ACT - LOGICAL SCALE - INTEGER MAX_NNZERO -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - integer :: debug_level, debug_unit -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - - NAME = 'SCRCO' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF (psb_toupper(TRANS).EQ.'N') THEN - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - IP1(1) = 0 - IP2(1) = 0 - NNZ = IA2(M+1)-1 - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': entry',m,n,nnz, - + ' : ',descra,' : ',descrn - - IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ - INT_VAL(3) = LARN - ELSE IF (LIAN1.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN1 - ELSE IF (LIAN2.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN2 - ENDIF - - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN -C ... Construct COO Representation... - ELEM = 0 - - DO ROW = 1, M - DO J = IA2(ROW), IA2(ROW+1)-1 - ELEM = ELEM + 1 - IAN1(ELEM) = ROW - IAN2(ELEM) = IA1(J) - ARN(ELEM) = AR(J) - ENDDO - ENDDO - INFON(psb_nnz_) = elem - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': endloop',m,elem - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 -c$$$ CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$ * AUX(IWORK1)) -c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), -c$$$ * AUX(IWORK2),NJA,IER,SCALE) -C - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - -c$$$ CALL DVTFG('U',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$c * AUX(IWORK1),AUX(IWORK2),IAN1(M+1)) -c$$$ * AUX(IWORK1),IAN1(1),IAN1(M+5)) -c$$$ CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE) -C - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') THEN - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - -c$$$ CALL DVTFG('L',M,IA1,IA2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$c * AUX(IWORK1),AUX(IWORK2),IAN1(M+1)) -c$$$ * AUX(IWORK1),IAN1(1),IAN1(M+5)) -c$$$ CALL DVTMR(M,AR,IA1,IA2,ISTROW,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,NJA,IER,SCALE) - else - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - END IF -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO DO -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - else - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/scrcr.f b/base/serial/dp/scrcr.f deleted file mode 100644 index 808abf90a..000000000 --- a/base/serial/dp/scrcr.f +++ /dev/null @@ -1,317 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, -C DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, -C WORK,LWORK,IERROR) -C -C Purpose: CSR to CSR format conversion -C ======= -C -C Parameter: -C ========= -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will convert -C matrix A or the transpose of A as follows: -C TRANS = 'N' -> convert matrix A -C TRANS = 'T' or 'C' -> convert A' (the transpose of A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') -C and number of rows of matrix H -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A (A') -C and number of columns of matrix H -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - DOUBLE PRECISION array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IP1 - INTEGER array of dimension (M) -C On exit IP1 specifies the row permutation of matrix AN -C (IP1(1) == 0 if no permutation). -C -C DESCRN - CHARACTER*1 array of DIMENSION (9) -C On exit DESCRN describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C AN - DOUBLE PRECISION array of DIMENSION (LAN) -C On exit AN specifies the values of the output sparse -C matrix. If LAN=0, INT(AN(1)) is the minimum value for LAN -C satisfying DSPDP memory requirements. -C -C IAN1 - INTEGER array of dimension (LIAN1) -C On exit IAN1 holds integer information on output sparse -C matrix. Actual information will depend on data format used. -C If LIAN1=0, INT(IAN1(1)) is the minimum value for LIAN1 -C satisfying DSPDP memory requirements. -C -C IAN2 - INTEGER array of dimension (LIAN2) -C On exit IAN2 holds integer information on output sparse -C matrix. Actual information will depend on data format used. -C If LIAN2=0, INT(IAN2(1)) is the minimum value for LIAN2 -C satisfying DSPDP memory requirements. -C -C INFON - INTEGER array of dimension (10) -C On exit can hold auxiliary information on output matrices -C formats or environment of subsequent calls. -C -C IP2 - INTEGER array of dimension (M) -C On exit IP2 specifies the column permutation of matrix AN -C (IP2(1) == 0 if no permutation). -C -C LAN - INTEGER -C On entry LAN specifies the dimension of AN -C LAN must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C LIAN1 - INTEGER -C On entry LH1 specifies the dimension of IAN1 -C LH1 must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C LIAN2 - INTEGER -C On entry LIAN2 specifies the dimension of IAN2 -C LIAN2 must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPDP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK must satisfy memory necessary for the data conversion. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 error -C -C - SUBROUTINE SCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, - * DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, - * WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C -C .. Scalar Arguments .. - INTEGER M, N, LAN, LIAN1, LIAN2, LWORK, IERROR - CHARACTER TRANS, UNITD -C .. Array Arguments .. - real(psb_spk_) A(*), AN(*), D(*), WORK(LWORK) - INTEGER IA1(*), IA2(*), IAN1(*), IAN2(*), IP1(*), IP2(*), - * INFOA(*), INFON(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER I, J, ERR_ACT - LOGICAL EXIT -c .. Local Arrays .. - character idescra*11 - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - -C .. Executable Statements .. -C - EXIT=.FALSE. - NAME = 'SCRCR' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) -C -C Check for argument errors -C - idescra=psb_toupper(descra) - IF (((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. - & idescra(1:1) .EQ. 'A') .AND. (psb_toupper(unitd) .NE. 'B')) - + .OR. - & (.NOT.((idescra(3:3).EQ.'N').OR.(idescra(3:3).EQ.'L').OR. - + (idescra(3:3).EQ.'U'))) - + .OR. - + psb_toupper(TRANS).NE.'N') THEN - IERROR = 20 - ENDIF - IF(LAN.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - AN(1) = REAL(IA2(M+1)-1) - ELSE - IERROR = 21 - ENDIF - ENDIF - IF(LIAN1.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN1(1) = IA2(M+1)-1 - ELSE - IERROR = 22 - ENDIF - ENDIF - IF(LIAN2.LT.(M+1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN2(1) = M+1 - ELSE - IERROR = 23 - ENDIF - ENDIF - IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. - & idescra(1:1) .EQ. 'A') .AND. - + (psb_toupper(UNITD) .EQ. 'B')) THEN - IF (LWORK.LT.M) THEN - IF (LWORK.LE.0) THEN - EXIT=.TRUE. - ELSE - IERROR = 25 - ENDIF - WORK(1) = REAL(M) - ENDIF - ELSE - IF (LWORK.LT.0) THEN - WORK(1) = 0.D0 - ENDIF - ENDIF -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (EXIT) goto 9998 -C -C Set DESCRN, IP1, IP2 -C - DESCRN(1:3) = idescra(1:3) - - IP1(1)=0 - IP2(1)=0 -C -C Compute output matrix -C - DO 20 I = 1, M+1 - IAN2(I) = IA2(I) - 20 CONTINUE - IF ((idescra(1:1) .EQ. 'S' .OR. idescra(1:1) .EQ. 'H' .OR. - & idescra(1:1) .EQ. 'A') .AND. - + (psb_toupper(UNITD) .EQ. 'B')) THEN - DO 30 I = 1, M - WORK(I) = SQRT(D(I)) - 30 CONTINUE - DO 40 I = 1, M - DO 50 J = IA2(I), IA2(I+1)-1 - AN(J) = WORK(I) * A(J) * WORK(IA1(J)) - IAN1(J) = IA1(J) - 50 CONTINUE - 40 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'L') THEN - DO 60 I = 1, M - DO 70 J = IA2(I), IA2(I+1)-1 - AN(J) = D(I) * A(J) - IAN1(J) = IA1(J) - 70 CONTINUE - 60 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'R') THEN - DO 80 I = 1, M - DO 90 J = IA2(I), IA2(I+1)-1 - AN(J) = A(J) * D(IA1(J)) - IAN1(J) = IA1(J) - 90 CONTINUE - 80 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'U') THEN - DO 100 J = 1, IA2(M+1)-1 - AN(J) = A(J) - IAN1(J) = IA1(J) - 100 CONTINUE - ENDIF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - - diff --git a/base/serial/dp/scrjd.f b/base/serial/dp/scrjd.f deleted file mode 100644 index e39d66cc9..000000000 --- a/base/serial/dp/scrjd.f +++ /dev/null @@ -1,315 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SCRJD(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, - * LIAN2,AUX,LAUX,SIZE_REQ,IERROR) -C -C Purpose -C ======= -C -C DCRJD converts a CSR matrix into a Jagged Diagonal. -C -C -C Notes -C ===== -C -C Parameters -C ========== -C -C TRANS Whether the transpose should be converted. -C -C M,N Size of input matrix A -C -C UNITD Scaling by diagonal D: 'U'nit, 'L'eft, 'R'ight -C D(*) -C -C DESCRA Input matrix A. -C AR,IA1, -C IA2,INFO -C -C DESCRN Output matrix in JAD format -C ARN,IAN1 -C IAN2,INFON, IP1, IP2 -C - use psb_const_mod - use psb_serial_mod - use psb_string_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, N, - * SIZE_REQ, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - real(psb_spk_) AR(*), ARN(LARN), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(LIAN1), - + IAN2(LIAN2), INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER IOFF, ISTROW, NJA, NZ, PIA, - + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT - LOGICAL SCALE - CHARACTER UPLO - INTEGER MAX_NNZERO -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5), IERRV(5) - -C .. External Subroutines .. - EXTERNAL DVTFG - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - NAME = 'SCRJD' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (LAUX.LT.4) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = 4 - INT_VAL(3) = LAUX - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IF (psb_toupper(TRANS).EQ.'N') THEN -C - NJA = 3*M - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - IOFF = 5 -C -C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX -C - PNG = IOFF - PIA = PNG + 1 - PJA = PIA + 3*(M+2) - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN - -C -C CHECK ON DIMENSION OF IAN2 AND AUX -C - MAX_NG = M/PSB_MINJDROWS_+1 - - IF ((PIA+3*(MAX_NG+1).GT.LIAN2).OR.(M+1 .GT. LAUX)) THEN -C ... If I haven't sufficent memory to compute NG in IAN2 ... - IF (M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1.GT.LAUX) THEN -C ... If I haven't sufficent memory to compute NG in AUX ... - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1 - INT_VAL(3) = LAUX - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE -C ... I have sufficent memory to compute NG in AUX ... - CALL DGBLOCK(M,IA2,IP1,AUX(M+2),NG, AUX, LAUX) - CALL CHECK_DIM(M,N,AUX(M+2),NG,IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - IF (IERRV(1).NE.0) THEN - SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) - - GOTO 9998 - ENDIF - ENDIF - END IF - - NZ = IA2(M+1) - 1 -C -C ... Initialize Permutation Matrix ... -C - DO 10 K = 1, M - IP1(K) = K - 10 CONTINUE - - IP2(1) = 0 - - CALL DGBLOCK(M,IA2,IP1,IAN2(PIA),IAN2(PNG), AUX, LAUX) - - PJA = PIA + 3*(IAN2(PNG)+1) -C -C CHECK FOR ARRAY DIMENSIONS -C - CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - IF (IERRV(1) .NE.0) THEN - SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) - GOTO 9998 - ENDIF - - LJA = LIAN2-PJA - CALL SGINDEX(M,IAN2(PNG),AR,IA1,IA2,info, - + ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON, - + LARN,LIAN1, LJA,IP1, - + AUX, LAUX, SIZE_REQ,IERROR) - - IF (IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - DESCRN(1:1) = 'G' - DESCRN(2:2) = 'U' - DESCRN(3:3) = 'N' - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN -C - ISTROW = 1 - NZ = 2*(IA2(M+1)-1) - M -C -C CHECK ON DIMENSION OF IAN1 AND ARN -C - IF (NZ .GT. LIAN1) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NZ - INT_VAL(3) = LAUX - LIAN1 = NZ - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (NZ .GT. LARN) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NZ - INT_VAL(3) = LAUX - LIAN1 = NZ - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - -c$$$ CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$ * AUX(IWORK1)) -c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), -c$$$ * AUX(IWORK2),NJA,IER,SCALE) -C - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T') THEN -C -C Only unit diagonal so far for triangular matrices. -C - - - IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN - IERROR=3022 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - UPLO = DESCRA(2:2) - NZ = IA2(M+1) - 1 -C -C ...Compute levels... -C Each level correspond to a block -C IAN1 is used as a work area - - CALL DVTFG(UPLO,M,IA1,IA2,IAN2(PNG),IP2,IP1,IAN1, - + AUX,AUX(M+1),AUX(2*(M+1))) - -C Generate IA(1,*) - DO K = 1, IAN2(PNG)+1 - IAN2(PIA+3*(K-1)) = IAN1(K) - ENDDO - - CALL GEN_BLOCK(M,IAN2(PNG),IAN2(PIA),AUX) - - PJA = PIA + 3*(IAN2(PNG)+1) - -C -C CHECK FOR ARRAY DIMENSIONS -C - - CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - - IF (IERRV(1).NE.0) THEN - size_req = max(ierrv(2),ierrv(3),ierrv(4)) -c$$$ write(0,*) "error 2",ierrv(1) - GOTO 9998 - endif - LJA = LIAN2-PJA - - CALL SGIND_TRI(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), - + IAN2(PJA),LARN,LIAN1,LJA,IP1,AUX, LAUX, IERROR) - - IF (IERROR.NE.0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - DESCRN(1:1) = 'T' - DESCRN(2:3) = psb_toupper(DESCRA(2:3)) - - END IF -C -C SET THE OUTPUT PARAMETER -C - IAN2(1) = PNG - IAN2(2) = PIA - IAN2(3) = PJA - LARN = NZ - LIAN1 = NZ - LIAN2 = 3*M + 10 - LAUX2 = 4*M + 2 -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO BE DONE -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/sgind_tri.f b/base/serial/dp/sgind_tri.f deleted file mode 100644 index 3a8e15cbe..000000000 --- a/base/serial/dp/sgind_tri.f +++ /dev/null @@ -1,237 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, - + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) - - use psb_const_mod - IMPLICIT NONE - -C ... Scalar arguments ... - - INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, IERROR - -C ... Array arguments ... - - real(psb_spk_) A(*), ARN(*), WORK(*) - INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(M), JA(*) - -C .... Local scalars ... - INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, - + DIM_BLOCK, LIMIT, ERR_ACT - LOGICAL CSR -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'SGIND_TRI' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - POINT_AR = 1 - POINT_JA = 0 - IERROR = 0 - - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C .... Invert Permutation Matrix... - IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO - ENDIF - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - ARN(POINT_AR) = 0.D0 -C -C The following statement assumes that we never get here with POINT_AR=1 -C - KA (POINT_AR) = KA(POINT_AR-1) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IPERM(IA1(IA2(ROW)+COL-1)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - 998 CONTINUE - - ENDIF - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IPERM(IA1(J)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - IA(2,N_BLOCKS+1) = POINT_JA - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/sgindex.f b/base/serial/dp/sgindex.f deleted file mode 100644 index 7112a6dcc..000000000 --- a/base/serial/dp/sgindex.f +++ /dev/null @@ -1,463 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON, - + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) - - use psb_const_mod - use psb_spmat_type - IMPLICIT NONE - -C ... Scalar arguments ... - INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, - + SIZE_REQ,IERROR - -C ... Array arguments ... - - real(psb_spk_) A(*), ARN(LARN) - INTEGER IA1(*), IA2(*), KA(LKA), - + IA(3,*), IPERM(*), JA(LJA), WORK(*),INFON(*), infoa(*) - -C .... Local scalars ... - INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1, - + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG, - + ERR_ACT, ix, regen_flag - LOGICAL CSR -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'DGINDEX\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - POINT_AR = 1 - POINT_JA = 0 - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - - - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - NNZ = IA2(M + 1) - 1 - COUNT = 0 - -C .... Invert Permutation Matrix... - IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO - ENDIF - - size_Req=0 - - IF ( (regen_flag == psb_upd_perm_) - + .AND. (LWORK .GE. (M + NNZ+2))) THEN -C -C Prepare for smart regeneration -C - - IPW = M + 2 - IP1 = (LKA-PSB_IREG_FLGS_-2)/2 - IP2 = IP1+PSB_IREG_FLGS_ - IPC = IP2 + NNZ + 1 - KA(IP1 + PSB_IPC_) = IPC - KA(IP1+PSB_IP2_) = IP2 - INFON(PSB_UPD_PNT_) = IP1 - KA(IP1+PSB_IFLAG_) = CHECK_FLAG - KA(IP1+PSB_NNZT_) = NNZ - KA(IP1+PSB_NNZ_) = 0 - KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG - - if (infoa(psb_upd_pnt_) > 0) then - I = infoa(psb_upd_pnt_) - IPX = IA2(I+PSB_IP2_) -C Invert permutation for smart regeneration - - DO I = 1, NNZ - WORK(IPW + IA2(IPX + I -1) - 1) = I - ENDDO - else - ! No permutation available before, set identity. - DO I = 1, NNZ - WORK(IPW + I - 1) = I - ENDDO - endif -C Construct JAD matrix... - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) -c$$$ write(0,*) 'DGINDEX: BLOCK LOOP ',block,n_blocks,dim_block - if (dim_block .gt. PSB_MAXJDROWS_) then - write(0,*) 'Wrong value for dim_block',block, - + IA(1,BLOCK+1),IA(1,BLOCK) - return - endif - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - - COUNT = COUNT + 1 - ARN(POINT_AR) = 0.D0 - KA(POINT_AR) = KA(POINT_AR-1) - IF(POINT_AR.LT.IP1) THEN - KA(IPC + COUNT -1) = POINT_AR - ENDIF -C -C The following statement assumes that we never get here with POINT_AR=1 -C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA(POINT_AR) = IA1(IA2(ROW)+COL-1) - IF(POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + - + IA2(ROW) +COL -1-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF(IERROR.EQ.0) THEN - JA(POINT_JA+COL) = POINT_AR - ENDIF - COL = COL+1 - ENDDO - - ENDIF - 998 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - IF (POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + J-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - IA(2,N_BLOCKS+1) = POINT_JA - KA(IP1 + PSB_ZERO_) = COUNT - - IF (POINT_AR.GE.IP1) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF - - ELSE -c$$$ c write(*,*)'inizio a ciclare sui blocchi' - IP1 = LKA - PSB_ZERO_ - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 999 - ELSE - COUNT= COUNT+1 - ARN(POINT_AR) = 0.D0 - KA (POINT_AR) = KA(POINT_AR-1) -C -C The following statement assumes that we never get here with POINT_AR=1 -C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IA1(IA2(ROW)+COL-1) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 999 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - - ENDIF - 999 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - - - IA(2,N_BLOCKS+1) = POINT_JA - - IF (POINT_AR.GE.lka) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF - ENDIF - - infon(1)=point_ar-1 - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/zcoco.f b/base/serial/dp/zcoco.f deleted file mode 100644 index 32efe9037..000000000 --- a/base/serial/dp/zcoco.f +++ /dev/null @@ -1,306 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -c covert matrix from COO format to COO format -c - subroutine zcoco(trans,m,n,unitd,d,descra,ar,ia1,ia2,info, - * p1,descrn,arn,ia1n,ia2n,infon,p2,larn,lia1n, - * lia2n,aux,laux,ierror) - use psb_error_mod - use psb_const_mod - use psb_spmat_type - use psb_string_mod - use psb_ip_reord_mod - implicit none - -c .. scalar arguments .. - integer larn, laux, lia1n, lia2n, - + m, n, ierror - character trans,unitd -c .. array arguments .. - complex(psb_dpk_) :: ar(*), arn(*), d(*) - integer aux(0:laux-1) - integer ia1(*), ia2(*), info(*), ia1n(*), ia2n(*), - * infon(*), p1(*), p2(*) - character descra*11, descrn*11 -c .. local scalars .. - integer ipx, ip1, ip2, check_flag, err_act - integer nnz, k, i, j, nzl, iret - integer elem_in, elem_out - logical scale - integer max_nnzero - integer :: debug_level, debug_unit -c .. local arrays .. - character*20 name - integer int_val(5) -c -c ...common variables... -c this flag describe the action to do - -c .. external subroutines .. - external max_nnzero -c .. executable statements .. -c - - name = 'zcoco' - ierror = 0 - call fcpsb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - - if (psb_toupper(trans).eq.'N') then - scale = (psb_toupper(unitd).eq.'L') ! meaningless - p1(1) = 0 - p2(1) = 0 - - call psb_getifield(nnz,psb_nnz_,info,psb_ifasize_,ierror) - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': on entry nnz laux ', - + nnz,laux,larn,lia1n,lia2n - endif - if (laux.lt.nnz+2) then - ierror = 60 - int_val(1) = 22 - int_val(2) = nnz+2 - int_val(3) = laux - else if (larn.lt.nnz) then - ierror = 60 - int_val(1) = 18 - int_val(2) = nnz+2 - int_val(3) = laux - else if (lia1n.lt.nnz) then - ierror = 60 - int_val(1) = 19 - int_val(2) = nnz+2 - int_val(3) = laux - else if (lia2n.lt.m+1) then - ierror = 60 - int_val(1) = 20 - int_val(2) = nnz+2 - int_val(3) = laux - endif - -c -c error handling -c - if(ierror.ne.0) then - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - end if - - if (psb_toupper(descra(1:1)).eq.'G') then -c -c sort COO data structure -c - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': first sort',nnz - do k=1, nnz - arn(k) = ar(k) - ia1n(k) = ia1(k) - ia2n(k) = ia2(k) - enddo - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': second sort' - - if ((lia2n.ge.(2*nnz+psb_ireg_flgs_+1)) - + .and.(laux.ge.2*(2+nnz))) then -c -c prepare for smart regeneration -c - ipx = nnz+3 - do i=1, nnz - aux(ipx+i-1) = i - enddo - ip1 = nnz+2 - infon(psb_upd_pnt_) = ip1 - ip2 = ip1+psb_ireg_flgs_ - ia2n(ip1+psb_ip2_) = ip2 - ia2n(ip1+psb_iflag_) = check_flag - ia2n(ip1+psb_nnzt_) = nnz - ia2n(ip1+psb_nnz_) = 0 - ia2n(ip1+psb_ichk_) = nnz+check_flag - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': build check :',ia2n(ip1+psb_nnzt_) - -c .... order with key ia1n ... - call msort_up(nnz,ia1n,aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn, - + ia1n,ia2n,aux(ipx:),aux) -c .... order with key ia2n ... - - i = 1 - j = i - do while (i.le.nnz) - do while ((ia1n(j).eq.ia1n(i)).and. - + (j.le.nnz)) - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ia2n(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1), - + aux(ipx+i-1:ipx+i+nzl-1),aux) - i = j - enddo - - ia2n(ip2+aux(ipx+1-1)-1) = 1 - -c ... construct final COO representation... - elem_out = 1 -c ... insert remaining element ... - do elem_in = 2, nnz - if ((ia1n(elem_in).eq.ia1n(elem_out)).and. - + (ia2n(elem_in).eq.ia2n(elem_out))) then - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the first duplicated element ... - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_out) = arn(elem_out) + arn(elem_in) - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - end if - else - elem_out = elem_out + 1 - arn(elem_out) = arn(elem_in) - ia2n(ip2+aux(ipx+elem_in-1)-1) = elem_out - ia1n(elem_out) = ia1n(elem_in) - ia2n(elem_out) = ia2n(elem_in) - endif - enddo - - else - -c .... order with key ia1n ... - call msort_up(nnz,ia1n,aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn, - + ia1n,ia2n,aux) - -c .... order with key ia2n ... - - i = 1 - j = i - do while (i.le.nnz) - do while ((ia1n(j).eq.ia1n(i)).and. - + (j.le.nnz)) - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ia2n(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + ia1n(i:i+nzl-1),ia2n(i:i+nzl-1),aux) - i = j - enddo -c ... construct final COO representation... - elem_out = 1 -c ... insert remaining element ... - do elem_in = 2, nnz - if ((ia1n(elem_in).eq.ia1n(elem_out)).and. - + (ia2n(elem_in).eq.ia2n(elem_out))) then - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the first duplicated element ... - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_out) = arn(elem_out) + arn(elem_in) - end if - else - elem_out = elem_out + 1 - arn(elem_out) = arn(elem_in) - ia1n(elem_out) = ia1n(elem_in) - ia2n(elem_out) = ia2n(elem_in) - endif - enddo - endif - infon(psb_nnz_) = elem_out - infon(psb_srtd_) = psb_isrtdcoo_ - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': done rebuild COO',infon(1) - - else if (psb_toupper(descra(1:1)).eq.'S' .and. - + psb_toupper(descra(2:2)).eq.'U') then - - do 20 k = 1, m - p2(k) = k - 20 continue - - else if (psb_toupper(descra(1:1)).eq.'T' .and. - + psb_toupper(descra(2:2)).eq.'U') then - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - - else if (psb_toupper(descra(1:1)).eq.'T' .and. - + psb_toupper(descra(2:2)).eq.'L') then - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if -c - else if (psb_toupper(trans).ne.'N') then -c -c to do -c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if - - call fcpsb_erractionrestore(err_act) - return - - 9999 continue - call fcpsb_erractionrestore(err_act) - - if ( err_act .ne. 0 ) then - call fcpsb_serror() - return - endif - - return - end diff --git a/base/serial/dp/zcocr.f b/base/serial/dp/zcocr.f deleted file mode 100644 index 7b8e459a7..000000000 --- a/base/serial/dp/zcocr.f +++ /dev/null @@ -1,523 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Covert matrix from COO format to CSR Format -C Note: this never sets IP1 and P2! -C - SUBROUTINE ZCOCR(TRANS,M,N,UNITD,D,DESCRA,AR,JA,IA,INFO, - * P1,DESCRN,ARN,IAN1,IAN2,INFON,P2,LARN,LIAN1, - * LIAN2,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_ip_reord_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, - + N, IUPDUP, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - complex(psb_dpk_) AR(*), ARN(*), D(*) - INTEGER AUX(0:LAUX-1) - INTEGER JA(*), IA(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), P1(*), P2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - integer nnz, k, row, i, j, nzl, iret - integer ipx, ip1, ip2, check_flag, err_act - integer elem, elem_csr,regen_flag - logical scale - integer max_nnzero - integer, allocatable :: itmp(:) -c .. local arrays .. - character*20 name - integer int_val(5) - integer :: debug_level, debug_unit - -C -C ...Common variables... - -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - NAME = 'ZCOCR' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - - IF (psb_toupper(TRANS).EQ.'N') THEN - - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - P1(1) = 0 - P2(1) = 0 - nnz = info(1) - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),': On entry NNZ LAUX ', - + nnz,laux,larn,lian1,lian2 - endif - IF (LAUX.LT.NNZ+2) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = NNZ+2 - INT_VAL(3) = LAUX - ELSE IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ - INT_VAL(3) = LARN - ELSE IF (LIAN1.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN1 - ELSE IF (LIAN2.LT.M+1) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = M+1 - INT_VAL(3) = LIAN2 - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - allocate(itmp(nnz),stat=iret) - if (iret /= 0) then - call fcpsb_errpush(4010,name,int_val) - goto 9999 - end if - - do k=1, nnz - arn(k) = ar(k) - ian1(k) = ja(k) - itmp(k) = ia(k) - enddo - ! Mark as unavailable by default. - infon(psb_upd_pnt_) = 0 - - - IF (psb_toupper(descra(1:1)).EQ.'G') THEN -C -C Sort COO data structure -C - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': First sort',nnz - - if ((regen_flag==psb_upd_perm_).and. - + (lian2.ge.((m+1)+nnz+psb_ireg_flgs_+1)) - + .and.(laux.ge.2*(2+nnz))) then -C -C Prepare for smart regeneration -c - ipx = nnz+3 - do i=1, nnz - aux(ipx+i-1) = i - enddo - ip1 = m+2 - infon(psb_upd_pnt_) = ip1 - ip2 = ip1+psb_ireg_flgs_ - ian2(ip1+psb_ip2_) = ip2 - ian2(ip1+psb_iflag_) = check_flag - ian2(ip1+psb_nnzt_) = nnz - ian2(ip1+psb_nnz_) = 0 - ian2(ip1+psb_ichk_) = nnz+check_flag - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Build check :',ian2(ip1+psb_nnzt_) - -C .... Order with key IA ... - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux(ipx:),aux) - - if (debug_level >= psb_debug_serial_) then - do i=1, nnz-1 - if (itmp(i).gt.itmp(i+1)) then - write(debug_unit,*) trim(name), - + 'Sorting error:',i,itmp(i),itmp(i+1) - endif - enddo - write(debug_unit,*) trim(name), - + 'nnz :',m,nnz,itmp(nnz),ian1(nnz) - endif - -C .... Order with key JA ... - - I = 1 - J = I - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1), - + aux(ipx+i-1:ipx+i+nzl-1),aux) - i = j - enddo - -c ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -c ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem = elem+1 - elem_csr = elem_csr+1 -c ... insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -c ... insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - ian2(ip2+aux(ipx+elem-1)-1) = elem_csr-1 - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - - else -C .... Order with key IA ... - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - - i = j - enddo - - - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - endif - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': Done Rebuild CSR', - + ian2(m+1),ia(elem) - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - do 20 k = 1, m - p2(k) = k - 20 continue - - else if (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - i = j - enddo - - - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - else if (psb_toupper(descra(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') THEN - - call msort_up(nnz,itmp,aux,iret) - if (iret == 0) call psb_ip_reord(nnz,arn, - + itmp,ian1,aux) -C .... Order with key JA ... - i = 1 - j = i - do - if (i>nnz) exit - do - if (j>nnz) exit - if (itmp(j) /= itmp(i)) exit - j = j+1 - enddo - nzl = j - i - call msort_up(nzl,ian1(i),aux,iret) - if (iret == 0) call psb_ip_reord(nzl,arn(i:i+nzl-1), - + itmp(i:i+nzl-1),ian1(i:i+nzl-1),aux) - i = j - enddo - -C ... Construct CSR Representation... - elem = 1 - elem_csr = 1 -C ... Insert first element ... - do row = 1, itmp(1) - ian2(row) = 1 - enddo - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name), - + ': Rebuild CSR',ia(1),elem_csr - - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem = elem+1 - elem_csr = elem_csr+1 -C ... Insert remaining element ... - do row = itmp(1), m - do - if (elem > nnz) exit - if (itmp(elem) /= row) exit - if (itmp(elem).ne.itmp(elem-1)) then -c ... insert first element of a row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else if (ian1(elem).ne.ian1(elem-1)) then -C ... Insert other element of row ... - ian1(elem_csr) = ian1(elem) - arn(elem_csr) = arn(elem) - elem_csr = elem_csr+1 - else - if (check_flag.eq.psb_dupl_err_) then -c ... error, there are duplicated elements ... - ierror = 130 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - else if (check_flag.eq.psb_dupl_ovwrt_) then -c ... insert only the last duplicated element ... - arn(elem_csr-1) = arn(elem) - else if (check_flag.eq.psb_dupl_add_) then -c ... sum the duplicated element ... - arn(elem_csr-1) = arn(elem_csr-1) + arn(elem) - end if - endif - elem = elem + 1 - enddo - ian2(row+1) = elem_csr - enddo - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': Done Rebuild CSR', - + ian2(m+1),ia(elem) - - - end if -c - else if (psb_toupper(TRANS).NE.'N') then -c -c to do -c - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - end if - infon(1)=elem_csr-1 - - call fcpsb_erractionrestore(err_act) - return - - 9999 continue - call fcpsb_erractionrestore(err_act) - - if ( err_act .ne. 0 ) then - call fcpsb_serror() - return - endif - - return - end diff --git a/base/serial/dp/zcrco.f b/base/serial/dp/zcrco.f deleted file mode 100644 index 49392b667..000000000 --- a/base/serial/dp/zcrco.f +++ /dev/null @@ -1,168 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE ZCRCO(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, - * LIAN2,AUX,LAUX,IERROR) - - use psb_const_mod - use psb_spmat_type - use psb_string_mod - use psb_error_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LIAN1, LIAN2, M, N, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - complex(psb_dpk_) AR(*), ARN(*), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER NNZ, K, ROW, J - INTEGER ELEM, ERR_ACT - LOGICAL SCALE - INTEGER MAX_NNZERO -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - integer :: debug_level, debug_unit -C .. External Subroutines .. - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - - NAME = 'ZCRCO' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF (psb_toupper(TRANS).EQ.'N') THEN - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - IP1(1) = 0 - IP2(1) = 0 - NNZ = IA2(M+1)-1 - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': entry',m,n,nnz, - + ' : ',descra,' : ',descrn - - IF (LARN.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NNZ - INT_VAL(3) = LARN - ELSE IF (LIAN1.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN1 - ELSE IF (LIAN2.LT.NNZ) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = NNZ - INT_VAL(3) = LIAN2 - ENDIF - - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN -C ... Construct COO Representation... - ELEM = 0 - - DO ROW = 1, M - DO J = IA2(ROW), IA2(ROW+1)-1 - ELEM = ELEM + 1 - IAN1(ELEM) = ROW - IAN2(ELEM) = IA1(J) - ARN(ELEM) = AR(J) - ENDDO - ENDDO - INFON(psb_nnz_) = elem - - if (debug_level >= psb_debug_serial_) - + write(debug_unit,*) trim(name),': endloop',m,elem - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 -C - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN - -C - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') THEN - - ierror = 3021 - call fcpsb_errpush(ierror,name,int_val) - goto 9999 - - END IF -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO DO -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/zcrcr.f b/base/serial/dp/zcrcr.f deleted file mode 100644 index 30b216234..000000000 --- a/base/serial/dp/zcrcr.f +++ /dev/null @@ -1,315 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE ZCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, -C DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, -C WORK,LWORK,IERROR) -C -C Purpose: CSR to CSR format conversion -C ======= -C -C Parameter: -C ========= -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will convert -C matrix A or the transpose of A as follows: -C TRANS = 'N' -> convert matrix A -C TRANS = 'T' or 'C' -> convert A' (the transpose of A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') -C and number of rows of matrix H -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A (A') -C and number of columns of matrix H -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - DOUBLE PRECISION array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IP1 - INTEGER array of dimension (M) -C On exit IP1 specifies the row permutation of matrix AN -C (IP1(1) == 0 if no permutation). -C -C DESCRN - CHARACTER*1 array of DIMENSION (9) -C On exit DESCRN describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C AN - DOUBLE PRECISION array of DIMENSION (LAN) -C On exit AN specifies the values of the output sparse -C matrix. If LAN=0, INT(AN(1)) is the minimum value for LAN -C satisfying DSPDP memory requirements. -C -C IAN1 - INTEGER array of dimension (LIAN1) -C On exit IAN1 holds integer information on output sparse -C matrix. Actual information will depend on data format used. -C If LIAN1=0, INT(IAN1(1)) is the minimum value for LIAN1 -C satisfying DSPDP memory requirements. -C -C IAN2 - INTEGER array of dimension (LIAN2) -C On exit IAN2 holds integer information on output sparse -C matrix. Actual information will depend on data format used. -C If LIAN2=0, INT(IAN2(1)) is the minimum value for LIAN2 -C satisfying DSPDP memory requirements. -C -C INFON - INTEGER array of dimension (10) -C On exit can hold auxiliary information on output matrices -C formats or environment of subsequent calls. -C -C IP2 - INTEGER array of dimension (M) -C On exit IP2 specifies the column permutation of matrix AN -C (IP2(1) == 0 if no permutation). -C -C LAN - INTEGER -C On entry LAN specifies the dimension of AN -C LAN must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C LIAN1 - INTEGER -C On entry LH1 specifies the dimension of IAN1 -C LH1 must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C LIAN2 - INTEGER -C On entry LIAN2 specifies the dimension of IAN2 -C LIAN2 must satisfy memory required from the new data structure. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSPDP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK must satisfy memory necessary for the data conversion. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 error -C -C - SUBROUTINE ZCRCR(TRANS,M,N,UNITD,D,DESCRA,A,IA1,IA2,INFOA,IP1, - * DESCRN,AN,IAN1,IAN2,INFON,IP2,LAN,LIAN1,LIAN2, - * WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C -C .. Scalar Arguments .. - INTEGER M, N, LAN, LIAN1, LIAN2, LWORK, IERROR - CHARACTER TRANS, UNITD -C .. Array Arguments .. - complex(psb_dpk_) A(*), AN(*), D(*), WORK(LWORK) - INTEGER IA1(*), IA2(*), IAN1(*), IAN2(*), IP1(*), IP2(*), - * INFOA(*), INFON(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER I, J, ERR_ACT - LOGICAL EXIT -c .. Local Arrays .. - character idescra*11 - CHARACTER*20 NAME - INTEGER INT_VAL(5) - -C .. Intrinsic Functions .. - INTRINSIC DBLE, DSQRT - -C .. Executable Statements .. -C - EXIT=.FALSE. - NAME = 'ZCRCR' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) -C -C Check for argument errors -C - idescra=psb_toupper(descra) - IF(((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. - & IDESCRA(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .NE. 'B')).OR. - & (.NOT.((IDESCRA(3:3).EQ.'N').OR.(IDESCRA(3:3).EQ.'L').OR. - + (IDESCRA(3:3).EQ.'U'))) .OR. - + psb_toupper(TRANS).NE.'N') THEN - IERROR = 20 - ENDIF - IF(LAN.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - AN(1) = DBLE(IA2(M+1)-1) - ELSE - IERROR = 21 - ENDIF - ENDIF - IF(LIAN1.LT.(IA2(M+1)-1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN1(1) = IA2(M+1)-1 - ELSE - IERROR = 22 - ENDIF - ENDIF - IF(LIAN2.LT.(M+1)) THEN - IF (LAN.LE.0) THEN - EXIT=.TRUE. - IAN2(1) = M+1 - ELSE - IERROR = 23 - ENDIF - ENDIF - IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. - & IDESCRA(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .EQ. 'B')) THEN - IF (LWORK.LT.M) THEN - IF (LWORK.LE.0) THEN - EXIT=.TRUE. - ELSE - IERROR = 25 - ENDIF - WORK(1) = DBLE(M) - ENDIF - ELSE - IF (LWORK.LT.0) THEN - WORK(1) = 0.D0 - ENDIF - ENDIF -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (EXIT) goto 9998 -C -C Set DESCRN, IP1, IP2 -C - DESCRN(1:3) = IDESCRA(1:3) - - IP1(1)=0 - IP2(1)=0 -C -C Compute output matrix -C - DO 20 I = 1, M+1 - IAN2(I) = IA2(I) - 20 CONTINUE - IF ((IDESCRA(1:1) .EQ. 'S' .OR. IDESCRA(1:1) .EQ. 'H' .OR. - & IDESCRA(1:1) .EQ. 'A') .AND. (psb_toupper(UNITD) .EQ. 'B')) THEN - DO 30 I = 1, M - WORK(I) = DBLE(DSQRT(ABS(D(I)))) - 30 CONTINUE - DO 40 I = 1, M - DO 50 J = IA2(I), IA2(I+1)-1 - AN(J) = WORK(I) * A(J) * WORK(IA1(J)) - IAN1(J) = IA1(J) - 50 CONTINUE - 40 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'L') THEN - DO 60 I = 1, M - DO 70 J = IA2(I), IA2(I+1)-1 - AN(J) = D(I) * A(J) - IAN1(J) = IA1(J) - 70 CONTINUE - 60 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'R') THEN - DO 80 I = 1, M - DO 90 J = IA2(I), IA2(I+1)-1 - AN(J) = A(J) * D(IA1(J)) - IAN1(J) = IA1(J) - 90 CONTINUE - 80 CONTINUE - ELSE IF (psb_toupper(UNITD) .EQ. 'U') THEN - DO 100 J = 1, IA2(M+1)-1 - AN(J) = A(J) - IAN1(J) = IA1(J) - 100 CONTINUE - ENDIF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - - diff --git a/base/serial/dp/zcrjd.f b/base/serial/dp/zcrjd.f deleted file mode 100644 index acf1e4872..000000000 --- a/base/serial/dp/zcrjd.f +++ /dev/null @@ -1,315 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE ZCRJD(TRANS,M,N,UNITD,D,DESCRA,AR,IA1,IA2,INFO, - * IP1,DESCRN,ARN,IAN1,IAN2,INFON,IP2,LARN,LIAN1, - * LIAN2,AUX,LAUX,SIZE_REQ,IERROR) -C -C Purpose -C ======= -C -C ZCRJD converts a CSR matrix into a Jagged Diagonal. -C -C -C Notes -C ===== -C -C Parameters -C ========== -C -C TRANS Whether the transpose should be converted. -C -C M,N Size of input matrix A -C -C UNITD Scaling by diagonal D: 'U'nit, 'L'eft, 'R'ight -C D(*) -C -C DESCRA Input matrix A. -C AR,IA1, -C IA2,INFO -C -C DESCRN Output matrix in JAD format -C ARN,IAN1 -C IAN2,INFON, IP1, IP2 -C - use psb_const_mod - use psb_spmat_type - use psb_string_mod - IMPLICIT NONE - -C -C .. Scalar Arguments .. - INTEGER LARN, LAUX, LAUX2, LIAN1, LIAN2, M, N, - * SIZE_REQ, IERROR - CHARACTER TRANS,UNITD -C .. Array Arguments .. - complex(psb_dpk_) AR(*), ARN(*), D(*), AUX(LAUX) - INTEGER IA1(*), IA2(*), INFO(*), IAN1(*), IAN2(*), - * INFON(*), IP1(*), IP2(*) - CHARACTER DESCRA*11, DESCRN*11 -C .. Local Scalars .. - INTEGER IOFF, ISTROW, NJA, NZ, PIA, - + PJA, PNG, K, MAX_NG, NG, LJA, ERR_ACT - LOGICAL SCALE - CHARACTER UPLO - INTEGER MAX_NNZERO -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5), IERRV(5) - -C .. External Subroutines .. - EXTERNAL DVTFG - EXTERNAL MAX_NNZERO -C .. Executable Statements .. -C - NAME = 'ZCRJD\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (LAUX.LT.4) THEN - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = 4 - INT_VAL(3) = LAUX - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IF (psb_toupper(TRANS).EQ.'N') THEN -C - NJA = 3*M - SCALE = (psb_toupper(UNITD).EQ.'L') ! meaningless - IOFF = 5 -C -C SET THE VALUES OF POINTERS TO VECTOR IAN2 AND AUX -C - PNG = IOFF - PIA = PNG + 1 - PJA = PIA + 3*(M+2) - - IF (psb_toupper(DESCRA(1:1)).EQ.'G') THEN - -C -C CHECK ON DIMENSION OF IAN2 AND AUX -C - MAX_NG = M/PSB_MINJDROWS_+1 - - IF ((PIA+3*(MAX_NG+1).GT.LIAN2).OR.(M+1 .GT. LAUX)) THEN -C ... If I haven't sufficent memory to compute NG in IAN2 ... - IF (M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1.GT.LAUX) THEN -C ... If I haven't sufficent memory to compute NG in AUX ... - IERROR = 60 - INT_VAL(1) = 22 - INT_VAL(2) = M+1+3*(MAX_NG+1)/PSB_DBLEINT_+1 - INT_VAL(3) = LAUX - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ELSE -C ... I have sufficent memory to compute NG in AUX ... - CALL DGBLOCK(M,IA2,IP1,AUX(M+2),NG, AUX, LAUX*2) - CALL CHECK_DIM(M,N,AUX(M+2),NG,IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - IF (IERRV(1).NE.0) THEN - SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) - - GOTO 9998 - ENDIF - ENDIF - END IF - - NZ = IA2(M+1) - 1 -C -C ... Initialize Permutation Matrix ... -C - DO 10 K = 1, M - IP1(K) = K - 10 CONTINUE - - IP2(1) = 0 - - CALL DGBLOCK(M,IA2,IP1,IAN2(PIA),IAN2(PNG), AUX, LAUX*2) - - PJA = PIA + 3*(IAN2(PNG)+1) -C -C CHECK FOR ARRAY DIMENSIONS -C - CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - IF (IERRV(1) .NE.0) THEN - SIZE_REQ = MAX(IERRV(2),IERRV(3),IERRV(4)) - GOTO 9998 - ENDIF - - LJA = LIAN2-PJA - CALL ZGINDEX(M,IAN2(PNG),AR,IA1,IA2,info, - + ARN,IAN1,IAN2(PIA), IAN2(PJA), INFON, - + LARN,LIAN1, LJA,IP1, - + AUX, LAUX*2, SIZE_REQ,IERROR) - - IF (IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - DESCRN(1:1) = 'G' - DESCRN(2:2) = 'U' - DESCRN(3:3) = 'N' - - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'S' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') THEN -C - ISTROW = 1 - NZ = 2*(IA2(M+1)-1) - M -C -C CHECK ON DIMENSION OF IAN1 AND ARN -C - IF (NZ .GT. LIAN1) THEN - IERROR = 60 - INT_VAL(1) = 19 - INT_VAL(2) = NZ - INT_VAL(3) = LAUX - LIAN1 = NZ - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - IF (NZ .GT. LARN) THEN - IERROR = 60 - INT_VAL(1) = 18 - INT_VAL(2) = NZ - INT_VAL(3) = LAUX - LIAN1 = NZ - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - DO 20 K = 1, M - IP2(K) = K - 20 CONTINUE - -c$$$ CALL DVSSG(M,IA1,IA2,IP2,IAN2(PNG),IP1,IP2,AUX(IWLEN), -c$$$ * AUX(IWORK1)) -c$$$ CALL DVSMR(M,AR,IA1,IA2,IAN2(PNG),AUX(IWLEN),IP1,IP2, -c$$$ * IAN2(PIA),IAN2(PJA),IAN1,ARN,AUX(IWORK1), -c$$$ * AUX(IWORK2),NJA,IER,SCALE) -C - ELSE IF (psb_toupper(DESCRA(1:1)).EQ.'T') THEN -C -C Only unit diagonal so far for triangular matrices. -C - - - IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN - IERROR=3022 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - UPLO = DESCRA(2:2) - NZ = IA2(M+1) - 1 -C -C ...Compute levels... -C Each level correspond to a block -C IAN1 is used as a work area - - CALL DVTFG(UPLO,M,IA1,IA2,IAN2(PNG),IP2,IP1,IAN1, - + AUX,AUX(M+1),AUX(2*(M+1))) - -C Generate IA(1,*) - DO K = 1, IAN2(PNG)+1 - IAN2(PIA+3*(K-1)) = IAN1(K) - ENDDO - - CALL GEN_BLOCK(M,IAN2(PNG),IAN2(PIA),AUX) - - PJA = PIA + 3*(IAN2(PNG)+1) - -C -C CHECK FOR ARRAY DIMENSIONS -C - - CALL CHECK_DIM(M,N,IAN2(PIA),IAN2(PNG),IA2, - + NZ,LARN,LIAN1,LIAN2,IERRV) - - IF (IERRV(1).NE.0) THEN - size_req = max(ierrv(2),ierrv(3),ierrv(4)) -c$$$ write(0,*) "error 2",ierrv(1) - GOTO 9998 - endif - LJA = LIAN2-PJA - - CALL ZGIND_TRI(M,IAN2(PNG),AR,IA1,IA2,ARN,IAN1,IAN2(PIA), - + IAN2(PJA),LARN,LIAN1,LJA,IP1,AUX, LAUX*2, IERROR) - - IF (IERROR.NE.0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - DESCRN(1:1) = 'T' - DESCRN(2:3) = psb_toupper(DESCRA(2:3)) - - END IF -C -C SET THE OUTPUT PARAMETER -C - IAN2(1) = PNG - IAN2(2) = PIA - IAN2(3) = PJA - LARN = NZ - LIAN1 = NZ - LIAN2 = 3*M + 10 - LAUX2 = 4*M + 2 -C - ELSE IF (psb_toupper(TRANS).NE.'N') THEN -C -C TO BE DONE -C - IERROR = 3021 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/dp/zgind_tri.f b/base/serial/dp/zgind_tri.f deleted file mode 100644 index 7050a48d7..000000000 --- a/base/serial/dp/zgind_tri.f +++ /dev/null @@ -1,237 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE ZGIND_TRI(M,N_BLOCKS,A,IA1,IA2,ARN,KA,IA,JA, - + LARN,LKA,LJA,IPERM,WORK, LWORK, IERROR) - - use psb_const_mod - IMPLICIT NONE - -C ... Scalar arguments ... - - INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, IERROR - -C ... Array arguments ... - - complex(psb_dpk_) A(*), ARN(*), WORK(*) - INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(M), JA(*) - -C .... Local scalars ... - INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, - + DIM_BLOCK, LIMIT, ERR_ACT - LOGICAL CSR -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'ZGIND_TRI\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - POINT_AR = 1 - POINT_JA = 0 - IERROR = 0 - - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C .... Invert Permutation Matrix... - IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO - ENDIF - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - ARN(POINT_AR) = 0.D0 -C -C The following statement assumes that we never get here with POINT_AR=1 -C - KA (POINT_AR) = KA(POINT_AR-1) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IPERM(IA1(IA2(ROW)+COL-1)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - 998 CONTINUE - - ENDIF - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IPERM(IA1(J)) - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 10 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 12 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - IA(2,N_BLOCKS+1) = POINT_JA - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/dp/zgindex.f b/base/serial/dp/zgindex.f deleted file mode 100644 index f2d4263e5..000000000 --- a/base/serial/dp/zgindex.f +++ /dev/null @@ -1,463 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE ZGINDEX(M,N_BLOCKS,A,IA1,IA2,infoa,ARN,KA,IA,JA, INFON, - + LARN,LKA,LJA,IPERM,WORK, LWORK, SIZE_REQ, IERROR) - - use psb_const_mod - use psb_spmat_type - IMPLICIT NONE - -C ... Scalar arguments ... - INTEGER M, LWORK,N_BLOCKS,LARN,LKA,LJA, - + SIZE_REQ,IERROR - -C ... Array arguments ... - - complex(psb_dpk_) A(*), ARN(*) - INTEGER IA1(*), IA2(*), KA(*), - + IA(3,*), IPERM(*), JA(*), WORK(*),INFON(*), infoa(*) - -C .... Local scalars ... - INTEGER I, J, BLOCK, ROW, COL, POINT_AR, POINT_JA, IP1, - + IP2, IPX, NNZ, DIM_BLOCK, LIMIT, IPW,COUNT, IPC,CHECK_FLAG, - + ERR_ACT, ix, regen_flag - LOGICAL CSR -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) - - NAME = 'ZGINDEX\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - POINT_AR = 1 - POINT_JA = 0 - call psb_getifield(check_flag,psb_dupl_,infon,psb_ifasize_,ierror) - call psb_getifield(regen_flag,psb_upd_,infon,psb_ifasize_,ierror) - - - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - NNZ = IA2(M + 1) - 1 - COUNT = 0 - -C .... Invert Permutation Matrix... - IF (IPERM(1).NE.0) THEN - DO I = 1, M - WORK(IPERM(I)) = I - ENDDO - ENDIF - - size_Req=0 - - IF ( (regen_flag == psb_upd_perm_) - + .AND. (LWORK .GE. (M + NNZ+2))) THEN -C -C Prepare for smart regeneration -C - - IPW = M + 2 - IP1 = (LKA-PSB_IREG_FLGS_-2)/2 - IP2 = IP1+PSB_IREG_FLGS_ - IPC = IP2 + NNZ + 1 - KA(IP1 + PSB_IPC_) = IPC - KA(IP1+PSB_IP2_) = IP2 - INFON(PSB_UPD_PNT_) = IP1 - KA(IP1+PSB_IFLAG_) = CHECK_FLAG - KA(IP1+PSB_NNZT_) = NNZ - KA(IP1+PSB_NNZ_) = 0 - KA(IP1+PSB_ICHK_) = NNZ+CHECK_FLAG - - if (infoa(psb_upd_pnt_) > 0) then - I = infoa(psb_upd_pnt_) - IPX = IA2(I+PSB_IP2_) -C Invert permutation for smart regeneration - - DO I = 1, NNZ - WORK(IPW + IA2(IPX + I -1) - 1) = I - ENDDO - else - ! No permutation available before, set identity. - DO I = 1, NNZ - WORK(IPW + I - 1) = I - ENDDO - endif -C Construct JAD matrix... - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) -c$$$ write(0,*) 'ZGINDEX: BLOCK LOOP ',block,n_blocks,dim_block - if (dim_block .gt. PSB_MAXJDROWS_) then - write(0,*) 'Wrong value for dim_block',block, - + IA(1,BLOCK+1),IA(1,BLOCK) - return - endif - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 998 - ELSE - - COUNT = COUNT + 1 - ARN(POINT_AR) = 0.D0 - KA(POINT_AR) = KA(POINT_AR-1) - IF(POINT_AR.LT.IP1) THEN - KA(IPC + COUNT -1) = POINT_AR - ENDIF -C -C The following statement assumes that we never get here with POINT_AR=1 -C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA(POINT_AR) = IA1(IA2(ROW)+COL-1) - IF(POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + - + IA2(ROW) +COL -1-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 998 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - IF(IERROR.EQ.0) THEN - JA(POINT_JA+COL) = POINT_AR - ENDIF - COL = COL+1 - ENDDO - - ENDIF - 998 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - IF (POINT_AR.LT.IP1) THEN - KA(IP2 + WORK(IPW + J-1)-1) = POINT_AR - ENDIF - - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - IA(2,N_BLOCKS+1) = POINT_JA - KA(IP1 + PSB_ZERO_) = COUNT - - IF (POINT_AR.GE.IP1) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF - - ELSE -c$$$ c write(*,*)'inizio a ciclare sui blocchi' - IP1 = LKA - PSB_ZERO_ - - DO BLOCK = 1, N_BLOCKS - COL = 1 - DIM_BLOCK = IA(1,BLOCK+1)-IA(1,BLOCK) - LIMIT = INT(DIM_BLOCK*PSB_PERCENT_) - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(2,BLOCK) = POINT_JA - JA(POINT_JA) = POINT_AR - CSR = .FALSE. - - IF (DIM_BLOCK.NE.0) THEN -C ... If current block is not empty ... -C ... For each Column belonging to Block ... - DO WHILE(.TRUE.) -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... If the current row is too short ... - IF (IA2(ROW)+COL-1.GE.IA2(ROW+1)) THEN -C ... Switch to CSR representation ... - IF (I.LE.IA(1,BLOCK)+LIMIT) THEN - CSR=.TRUE. - POINT_AR = POINT_AR - I + IA(1,BLOCK) - GOTO 999 - ELSE - COUNT= COUNT+1 - ARN(POINT_AR) = 0.D0 - KA (POINT_AR) = KA(POINT_AR-1) -C -C The following statement assumes that we never get here with POINT_AR=1 -C - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE - ARN(POINT_AR) = A(IA2(ROW)+COL-1) - KA (POINT_AR) = IA1(IA2(ROW)+COL-1) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) - + THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDDO - - IF (CSR) GOTO 999 - - IF (LJA.LT.POINT_JA+COL) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - JA(POINT_JA+COL) = POINT_AR - COL = COL+1 - ENDDO - - ENDIF - 999 CONTINUE - - POINT_JA = POINT_JA+COL-1 - - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IA(3,BLOCK) = POINT_JA - -C ... Start CSR Format ... - -C ... For each row belonging to the block BLOCK ... - DO I = IA(1,BLOCK), IA(1,BLOCK+1)-1 - IF (IPERM(1).EQ.0) THEN - ROW = I - ELSE - ROW = WORK(I) - ENDIF - -C ... For each nnzero elements belonging to current row ... - DO J = IA2(ROW)+COL-1, IA2(ROW+1)-1 - ARN(POINT_AR) = A(J) - KA (POINT_AR) = IA1(J) - POINT_AR = POINT_AR+1 - IF ((LARN.LT.POINT_AR).OR.(LKA.LT.POINT_AR)) THEN - IERROR = 60 - INT_VAL(1) = 11 - INT_VAL(2) = POINT_AR - INT_VAL(3) = LARN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDDO - - POINT_JA = POINT_JA+1 - IF (LJA.LT.POINT_JA) THEN - IERROR = 60 - INT_VAL(1) = 13 - INT_VAL(2) = POINT_JA - INT_VAL(3) = LJA - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - JA(POINT_JA) = POINT_AR - ENDDO - ENDDO - - - - IA(2,N_BLOCKS+1) = POINT_JA - - IF (POINT_AR.GE.lka) THEN - SIZE_REQ=NNZ+COUNT - ELSE - SIZE_REQ=0 - ENDIF - ENDIF - - infon(1)=point_ar-1 - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - diff --git a/base/serial/f77/Makefile b/base/serial/f77/Makefile index 5cc8e333e..52a024a3f 100644 --- a/base/serial/f77/Makefile +++ b/base/serial/f77/Makefile @@ -7,18 +7,6 @@ FOBJS = daxpby.o saxpby.o \ caxpby.o zaxpby.o smmp.o -# clpupd.o ccsmm.o cswmm.o ccsnmi.o ccsrws.o\ -# cswsm.o ccssm.o cgelp.o\ -# zcsnmi.o zcsmm.o zcssm.o zswmm.o zswsm.o\ -# zcsrws.o zgelp.o zlpupd.o - -#dcsmm.o dcsnmi.o dcsrp.o dcssm.o \ -# dgelp.o dlpupd.o dswmm.o \ -# dswsm.o smmp.o dcsrws.o \ -#slpupd.o scsmm.o sswmm.o scsnmi.o scsrws.o\ -#sswsm.o scssm.o - - OBJS=$(FOBJS) # diff --git a/base/serial/f77/ccsmm.f b/base/serial/f77/ccsmm.f deleted file mode 100644 index 686eb85f9..000000000 --- a/base/serial/f77/ccsmm.f +++ /dev/null @@ -1,380 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE CCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, -C INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C Purpose -C ======= -C -C Computing matrix-matrix product -C C <-- ALPHA PL A PR B + BETA C or -C C <-- ALPHA PL At PR B + BETA C or -C C <-- ALPHA PL Atc PR B + BETA C -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' -> use A' (transpose of matrix A) -C TRANS = 'C' -> use conjugate transpose of A -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C PL - INTEGER array of dimension (M) -C On entry PL specifies the row permutation of matrix A -C (PL(1) == 0 if no permutation). -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - COMPLEX*16 array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C PR - INTEGER array of dimension (K) -C On entry PR specifies the column permutation of matrix A -C (PR(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - COMPLEX*16 matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying CCSMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = (LWORK for DxxxMM) + Pr*K*N + Pl*M*N -C where Pr íPlù = 1 if right íleftù permutation has to -C be performed, 0 otherwise. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Local Variables -C =============== -C -C LWORKM - INTEGER -C Minimum work area dimension for CCSMM -C -C LWORKB - INTEGER -C Work area dimension for matrix B in subroutine DLPUPD -C -C LWORKC - INTEGER -C Work area dimension for matrix C in subroutine DLPUPD -C -C LWORKS - INTEGER -C Work area dimension for subroutine DSWMM -C -C P - INTEGER -C Pointer to work area -C -C LP - LOGICAL -C LP is true if left permutation is required -C -C RP - LOGICAL -C RP is true if right permutation is required -C -C Notes -C ===== -C Some tests have shown that it is more efficient to divide the -C sparse matrix-dense matrix multiplication step and the dense -C matrix permutation step, and it is more efficient to put -C together the left permutation and update (C <- xxx + BETA C) -C steps. So, the sequence of operations is: -C Right permutation ZLPUPD -C Matrix-Matrix product ZSWMM -C Left permutation and update ZLPUPD -C In order to avoid useless memory transfer, the above scheme is -C simplified according to whether right and left permutation have to -C be performed. If left permutation is not required, the update step -C is performed in the sparse matrix-dense matrix multiplication kernel. -C -C It is not possible to call this subroutine with LWORK=0 to get # -C the minimal value for LWORK. This functionality needs a better # -C connection with DxxxMM # -C -C - SUBROUTINE CCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, - & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N,K,LDB,LDC,LWORK, IERROR - CHARACTER TRANS - complex(psb_spk_) ALPHA,BETA -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*),PL(*),PR(*) - CHARACTER DESCRA*11, FIDA*5 - complex(psb_spk_) A(*),B(LDB,*),C(LDC,*),WORK(*) -C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P, ERR_ACT - LOGICAL LP, RP -C .. Local Array.. - INTEGER INT_VAL(5) - CHARACTER*30 NAME, STRINGS(2) -C .. External Subroutines .. - EXTERNAL ZSWMM, ZLPUPD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT -C .. Executable Statements .. -C -C Check for argument errors -C - NAME = 'CCSMM\0' - IERROR=0 - - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (K.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 4 - INT_VAL(2) = K - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (LDB.LT.K) THEN - IERROR = 50 - INT_VAL(1) = 15 - INT_VAL(2) = 4 - INT_VAL(3) = LDB - INT_VAL(4) = K - ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 18 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Inizializations -C - LP = PL(1).NE.0 - RP = PR(1).NE.0 - LWORKB = K*N - LWORKC = M*N - LWORKM = 0 - IF (RP) LWORKM = LWORKB - IF (LP) LWORKM = LWORKM + LWORKC - IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - LWORKS = LWORK - LWORKM - -C -C Check for M, N, K -C - IF(M.LE.0 .OR. N.LE.0 .OR. K.LE.0) THEN - GOTO 9999 - ENDIF -C -C Switching on PR and PL -C - IF (LP .AND. RP) THEN -C -C Both right and left permutation required -C - P=LWORKB+1 - CALL CLPUPD(K,N,PR,B,LDB,CZERO,WORK,K) - CALL CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,CZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) - LWORKS = INT(REAL(WORK(P+LWORKC))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDA//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL CLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) - ELSE IF(.NOT.LP .AND. RP) THEN -C -C Only right permutation required -C - P=LWORKB+1 - CALL CLPUPD(K,N,PR,B,LDB,CZERO,WORK,K) - CALL CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) - LWORKS = INT(REAL(WORK(P))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDA//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE IF(.NOT.RP .AND. LP) THEN -C -C Only left permutation required -C - P=LWORKC+1 - CALL CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,CZERO,WORK,M,WORK(P),LWORKS,IERROR) - LWORKS = INT(REAL(WORK(P))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDA//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - - CALL CLPUPD(M,N,PL,WORK,M,BETA,C,LDC) - ELSE IF(.NOT.RP .AND. .NOT.LP) THEN -C -C No permutations required -C - CALL CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,BETA,C,LDC,WORK,LWORKS,IERROR) - LWORKS = INT(REAL(WORK(1))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDA//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - - GOTO 9999 - ENDIF - ENDIF - ENDIF -C -C Return minimum workarea dimension -C - LWORKM = LWORKM + LWORKS - WORK(1) = REAL(LWORKM) - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - - RETURN - END - - diff --git a/base/serial/f77/ccsnmi.f b/base/serial/f77/ccsnmi.f deleted file mode 100644 index f35d7d5f2..000000000 --- a/base/serial/f77/ccsnmi.f +++ /dev/null @@ -1,184 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C DOUBLE PRECISION FUNCTION CCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & -C & INFOA,IERROR) -C Purpose -C ======= -C -C Computing matrix infinity norm -C nrmi <-- ||A||infty or -C nrmi <-- ||At||infty -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Notes -C ===== -C - FUNCTION CCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE - real(psb_spk_) ccsnmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - complex(psb_spk_) A(*) -C .. Local Array.. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME, STRINGS(2) -C .. External Subroutines .. - real(psb_spk_) CCRNRMI, CCOONRMI - EXTERNAL CCRNRMI, CCOONRMI -C .. Executable Statements .. -C -C Check for argument errors -C - IERROR = 0 - NAME = 'CCSNMI\0' - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Check for M, N, K -C - IF(M.LE.0 .OR. N.LE.0) THEN - CCSNMI = 0.D0 - GOTO 9999 - ENDIF - -C ... Compute infinity norm for matrix A ... - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN - CCSNMI = CCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) -c$$$ ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN -c$$$ CCSNMI = CJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, -c$$$ + INFOA,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN - CCSNMI = CCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - RETURN - END diff --git a/base/serial/f77/ccsrws.f b/base/serial/f77/ccsrws.f deleted file mode 100644 index d8ef9f20a..000000000 --- a/base/serial/f77/ccsrws.f +++ /dev/null @@ -1,189 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE DCSRS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & -C & INFOA,ROWSUM,IERROR) -C Purpose -C ======= -C -C Computing sum of absolute values for rows of distributed matrix -C ROWSUM(IX) = ASUM(A(IX, 1..N)) -C IX = 1..M -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C ROWSUM - DOUBLE PRECISION array of dimension (*) -C On exit this vector contains the sum of absolute values -C of elements of a row (AMAX of row array). -C It is required that it has dimension: -C ROWSUM(M) if the subroutine in called with the 'N' option -C ROWSUM(N) in other cases ('T' or 'C' options). -C - SUBROUTINE CCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - complex(psb_spk_) A(*), ROWSUM(*) -C .. Local Array.. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME,STRINGS(2) -C .. Executable Statements .. -C -C Check for argument errors -C - - IERROR = 0 - NAME = 'CCSRWS\0' - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IF(M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 - ENDIF - - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN - CALL CCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN - CALL CCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) -c$$$ ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN -c$$$ CALL DJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2, -c$$$ + INFOA,ROWSUM,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - strings(1) = fida//'\0' - ENDIF - - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - - diff --git a/base/serial/f77/ccssm.f b/base/serial/f77/ccssm.f deleted file mode 100644 index 7c0e99aa9..000000000 --- a/base/serial/f77/ccssm.f +++ /dev/null @@ -1,376 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE CCSSM(TRANS,M,N,ALPHA,UNITD,D,PL,FIDT,DESCRT,T,IT1,IT2, -C INFOT,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Solving triangular systems of equations with multiple right-hand sides -C C <-- ALPHA PL D T-1 PR B + BETA C or -C C <-- ALPHA PL D T-t PR B + BETA C or -C C <-- ALPHA PL T-1 D PR B + BETA C or -C C <-- ALPHA PL T-t D PR B + BETA C -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine operates with -C matrix T or with the transpose of T as follows: -C TRANS = 'N' -> use matrix T -C TRANS = 'T' -> use T' (transpose of matrix T) -C TRANS = 'C' -> use conjugate transpose of T -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows and columns of matrix Ty -C and number of rows of matrices B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrices B and C -C (number of right-hand sides). -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - COMPLEX*16 array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C PL - INTEGER array of dimension (M) -C On entry PL specifies the row permutation of matrix T -C (PL(1) == 0 if no permutation). -C Unchanged on exit. -C -C FIDT - CHARACTER*5 -C On entry FIDT defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRT - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRT describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C -C T - CONPLEX*16 array of DIMENSION (*) -C On entry T specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IT1 - INTEGER array of dimension (*) -C On entry IT1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IT2 - INTEGER array of dimension (*) -C On entry IT2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOT - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C PR - INTEGER array of dimension (M) -C On entry PR specifies the column permutation of matrix T -C (PR(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - COMPLEX*16 array of dimension (LDB,*) -C On entry: matrix of right-hand sides -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 array of dimension (LDC,*) -C On exit: solutions of triangular systems -C -C LDC - INTEGER -C On entry: leading dimension of C. -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DCSSM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = (LWORK for DxxxSM) + Pr*M*N + Pl*M*N -C where Pr íPlù = 1 if right íleftù permutation has to -C be performed, 0 otherwise. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Local Variables -C =============== -C -C LWORKM - INTEGER -C Minimum work area dimension for CCSSM -C -C LWORKB - INTEGER -C Work area dimension for matrices B, C in subroutines ZLPUPD -C -C LWORKS - INTEGER -C Work area dimension for subroutine ZSWSM -C -C P - INTEGER -C Pointer to work area -C -C LP - LOGICAL -C LP is true if left permutation is required -C -C RP - LOGICAL -C RP is true if right permutation is required -C -C Notes -C ===== -C Some tests have shown that it is more efficient to divide the -C sparse matrix-dense matrix multiplication step and the dense -C matrix permutation and update (C <- xxx + BETA C) step. -C So, the sequence of operations is: -C Right permutation ZLPUPD -C Matrix-Matrix product ZSWSM -C Left permutation and update ZLPUPD -C In order to avoid useless memory transfer, the above scheme is -C simplified according to whether right and left permutation -C have to be performed. -C -C - SUBROUTINE CCSSM(TRANS,M,N,ALPHA,UNITD,D,PL, - + FIDT,DESCRT,T,IT1,IT2,INFOT,PR,B,LDB,BETA,C,LDC, - + WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - IMPLICIT NONE - complex(psb_spk_) ALPHA, BETA - INTEGER N, LDB, LDC, M, LWORK, IERROR - CHARACTER UNITD, TRANS -C .. Array Arguments .. - complex(psb_dpk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IT1(*), IT2(*), INFOT(*), PL(*), PR(*) - CHARACTER DESCRT*11, FIDT*5 -C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKS, P - complex(psb_spk_) ZERO - LOGICAL LP, RP -C .. Local Array.. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME, STRINGS(2) -C .. Parameters .. - PARAMETER (ZERO = (0.0, 0.0)) -C .. Executable Statements .. -C -C Check for argument errors -C - NAME = 'CCSSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (psb_toupper(UNITD).NE.'U' .AND. - + psb_toupper(UNITD).NE.'L' .AND. - + psb_toupper(UNITD).NE.'R' .AND. - + psb_toupper(UNITD).NE.'B') THEN - IERROR = 40 - INT_VAL(1) = 5 - STRINGS(1) = UNITD//'\0' - ELSE IF (LDB.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 16 - INT_VAL(2) = 2 - INT_VAL(3) = LDB - INT_VAL(4) = M - ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 19 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Inizializations -C - LP = PL(1).NE.0 - RP = PR(1).NE.0 - LWORKB = M*N - LWORKM = 0 - IF (RP) LWORKM = LWORKB - IF (LP) LWORKM = LWORKM + LWORKB - P = LWORKB+1 - IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 21 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - LWORKS = LWORK - LWORKM - -C Check for M, N -C - IF (M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 - ENDIF -C -C Switching on xP -C - IF (LP .AND. RP) THEN -C -C Both right and left permutations required -C - CALL CLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,ZERO,WORK(P),M,WORK(P+LWORKB),lworks,IERROR) - LWORKS = INT(REAL(WORK(P+LWORKB))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDT//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL CLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) - ELSE IF(.NOT.LP .AND. RP) THEN -C -C Only right permutation required -C - CALL CLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,ZERO,C,LDC,WORK(P),lworks,IERROR) - LWORKS = INT(REAL(WORK(P))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDT//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE IF(.NOT.RP .AND. LP) THEN -C -C Only left permutation required -C - CALL CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,WORK,M,WORK(P),lworks,IERROR) - LWORKS = INT(REAL(WORK(P))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDT//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL CLPUPD(M,N,PL,WORK,M,BETA,C,LDC) - ELSE IF(.NOT.RP .AND. .NOT.LP) THEN -C -C Only triangular systems solver required -C - CALL CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,lworks,IERROR) - LWORKS = INT(REAL(WORK(1))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDT//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDIF -C -C Return minimum workarea dimension -C - LWORKM = LWORKM + LWORKS - WORK(1) = REAL(LWORKM) - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - RETURN - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - ENDIF - RETURN - - END - diff --git a/base/serial/f77/cgelp.f b/base/serial/f77/cgelp.f deleted file mode 100644 index 2e9d9959c..000000000 --- a/base/serial/f77/cgelp.f +++ /dev/null @@ -1,204 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C Computing -C B <-- op(P) B -C where op(P) is permutation matrix P or its transpose. -C Notice: when B is a diagonal matrix and it is stored as -C a vector whose entry i is B(i,i), this routine computes -C B <-- P B P(-1) -C where P(-1) is the inverse of P. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whetherif the routine operates with -C matrix P or with the transpose of P as follows: -C TRANS = 'N' -> use matrix P -C TRANS = 'T' OR 'C' -> use the transpose of matrix P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix B. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B. -C Unchanged on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the row permutation of matrix B -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of dimension (LDB,*) -C On entry: dense matrix. -C On exit: permuted matrix. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DGELP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = M -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C - SUBROUTINE CGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LDB, M, N, LWORK, IERROR - CHARACTER TRANS -C .. Array Arguments .. - complex(psb_spk_) B(LDB,*), WORK(*) - INTEGER P(*) -C .. Local Scalars .. - INTEGER I, J, ERR_ACT - logical istran,isnotran -C .. Local Arrays.. - INTEGER INT_VAL -C .. Intrinsic Functions .. - INTRINSIC DBLE - logical psb_lsame - external psb_lsame - - character*20 name -c -C .. Executable Statements .. -C -C -C Check on M, N, LDB, LWORK, TRANS -C - NAME = 'CGELP\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - isnotran = psb_lsame(psb_toupper(trans),'N') - istran = psb_lsame(psb_toupper(trans),'T') .or. - + psb_lsame(psb_toupper(trans),'C') - IF (M.LT.0) THEN - IERROR = 7 - ELSE IF(N.LT.0) THEN - IERROR = 3 - ELSE IF(M.GT.LDB) THEN - IERROR = -6 - ELSE IF (LWORK.LT.M) THEN - IF (LWORK.EQ.0) THEN -C -C Return minimum LWORK -C - IERROR = 8 - WORK(1) = REAL(M) - GOTO 9998 - ELSE IF(LWORK.NE.0) THEN - IERROR = -8 - ENDIF - ELSE IF (.not.istran.and..not.isnotran) THEN - IERROR = -1 - ENDIF -C -C Error handling -C - IF(IERROR.LT.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Check for M, N, P -C - IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Switch on TRANS -C - IF (isnotran) THEN -C -C Permuting with P -C - DO 60 J = 1, N - DO 20 I = 1, M - WORK(I) = B(P(I),J) - 20 CONTINUE - DO 40 I = 1, M - B(I,J) = WORK(I) - 40 CONTINUE - 60 CONTINUE - ELSE IF (istran) THEN -C -C Permuting with the transpose of P. -C - DO 160 J = 1, N - DO 120 I = 1, M - WORK(P(I)) = B(I,J) - 120 CONTINUE - DO 140 I = 1, M - B(I,J) = WORK(I) - 140 CONTINUE - 160 CONTINUE - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/clpupd.f b/base/serial/f77/clpupd.f deleted file mode 100644 index 87768b3e1..000000000 --- a/base/serial/f77/clpupd.f +++ /dev/null @@ -1,116 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Subroutine CLPUPD(M,N,PERM,B,LDB,BETA,C,LDC,IERROR) -C Purpose -C ======= -C -C Computing C <-- PERM B + BETA C -C where PERM is a permutation matrix. -C -C Parameters -C ========== -C -C M - INTEGER -C On entry M specifies the number of rows of matrices -C B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry N specifies the number of columns of matrices -C B and C. -C Unchanged on exit. -C -C PERM - INTEGER array of dimension (N) -C On entry PERM specifies the values of a permutation matrix. -C Unchanged on exit. -C -C B - DOUBLE PRECISION matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry LDB holds the value of the leading dimension of B -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated as shown above. -C -C LDC - INTEGER -C On entry LDC holds the value of the leading dimension of C -C Unchanged on exit. -C -C Note -C ==== -C All checks on argument are performed in the calling routines. -C -C - SUBROUTINE CLPUPD(M,N,PERM,B,LDB,BETA,C,LDC) - use psb_const_mod -C .. Scalar Arguments .. - INTEGER M, N, LDB, LDC - complex(psb_spk_) BETA -C .. Array Arguments .. - INTEGER PERM(*) - complex(psb_spk_) B(LDB,*), C(LDC,*) -C .. Local Scalars .. - INTEGER I,J -C -C .. Executable Statements .. -C -C Switching on BETA -C - IF (BETA.NE.CZERO) THEN -C -C Performing left permutation and update -C - DO 40 J = 1, N - DO 30 I = 1, M - C(I,J) = B(PERM(I),J) + BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - ELSE IF(BETA.EQ.CZERO) THEN -C -C Performing right or left permutation -C - DO 160 J = 1, N - DO 150 I = 1, M - C(I,J) = B(PERM(I),J) - 150 CONTINUE - 160 CONTINUE - ENDIF - RETURN - END diff --git a/base/serial/f77/cswmm.f b/base/serial/f77/cswmm.f deleted file mode 100644 index eab5c2857..000000000 --- a/base/serial/f77/cswmm.f +++ /dev/null @@ -1,220 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, -C INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C Purpose -C ======= -C -C Computing C <-- ALPHA A B + BETA C or -C C <-- ALPHA At B + BETA C or -C C <-- ALPHA Atc B + BETA C -C Called by ZCSMM -C Actual computing performed by sparse Toolkit kernels. -C This routine selects the proper kernel for each -C data structure. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' -> use A' (transpose of matrix A) -C TRANS = 'C' -> use conjugate transpose of A -C Unchanged on exit. -C -C N.B.: M, N for C matrix -C M, K for A matrix -C K, N for B matrix -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - COMPLEX*16 array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - COMPLEX*16 matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying CSWMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Note -C ==== -C All checks on argument are performed in the calling routine. -C -C - SUBROUTINE CSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, - & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - INTEGER M,N,K,LDB,LDC,LWORK,IERROR - CHARACTER TRANS - complex(psb_spk_) ALPHA,BETA -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - complex(psb_spk_) A(*),B(LDB,*),C(LDC,*),WORK(*) -C .. Local Array .. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME, STRINGS(2) -C .. External Subroutines .. - EXTERNAL CCSRMM -C + ZJADMM -C .. Executable Statements .. -C -C Switching on FIDA: proper sparse BLAS routine is selected -C according to data structure -C - NAME = 'CSWMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - WORK(1) = czero - - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN -C -C A, IA1, IA2 ---> AR, JA, IA -C VAL, INDX, PNTR -C INFOA(*) not used - CALL CCSRMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - & IA2,B,LDB,BETA,C,LDC,WORK,LWORK) -C -C JAD format not jet implemented -C - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN -C -C INFOA(*) not used -C - CALL CCOOMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - + IA2,INFOA,B,LDB,BETA,C,LDC,WORK) - ELSE IF ((psb_toupper(FIDA(1:3)).EQ.'JAD').AND.(.FALSE.)) THEN -C -C INFOA(*) not used -C -C CALL ZJADMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, -C & IA2,B,LDB,BETA,C,LDC,WORK) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - STRINGS(1) = FIDA(1:4) - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - END - diff --git a/base/serial/f77/cswsm.f b/base/serial/f77/cswsm.f deleted file mode 100644 index 5c09a1898..000000000 --- a/base/serial/f77/cswsm.f +++ /dev/null @@ -1,230 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, -C INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Solving triangular systems of equations with multiple right-hand sides -C C <-- ALPHA D T-1 B + BETA C or -C C <-- ALPHA D T-t B + BETA C or -C C <-- ALPHA T-1 D B + BETA C or -C C <-- ALPHA T-t D B + BETA C -C Actual computing performed by sparse Toolkit kernels. -C This routine selects the proper kernel for each -C data structure. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine operates with -C matrix T or with the transpose of T as follows: -C TRANS = 'N' -> use matrix T -C TRANS = 'T' -> use T' (transpose of matrix T) -C TRANS = 'C' -> use conjugate transpose of T -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows and columns of matrix T -C and number of rows of matrices B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrices B and C -C (number of right-hand sides). -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - COMPLEX*16 array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C FIDT - CHARACTER*5 -C On entry FIDT defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRT - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRT describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C -C T - COMPLEX*16 array of DIMENSION (*) -C On entry T specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IT1 - INTEGER array of dimension (*) -C On entry IT1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IT2 - INTEGER array of dimension (*) -C On entry IT2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOT - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - COMPLEX*16 array of dimension (LDB,*) -C On entry: matrix of right-hand sides -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 array of dimension (LDC,*) -C On exit: solutions of triangular systems -C -C LDC - INTEGER -C On entry: leading dimension of C. -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSWSM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Note -C ==== -C All checks on argument are performed in the calling routine. -C -C - SUBROUTINE CSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - INTEGER M, N, LDB, LDC, LWORK, IERROR - CHARACTER UNITD, TRANS - complex(psb_spk_) ALPHA, BETA -C .. Array Arguments .. - INTEGER IT1(*), IT2(*), INFOT(*) - CHARACTER DESCRT*11, FIDT*5 - complex(psb_spk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - integer ERR_ACT -C .. Local Scalars .. - INTEGER ONE -C .. Parameters .. - PARAMETER (ONE=1) -C .. External Subroutines .. - EXTERNAL CCSRSM, CCOPY - CHARACTER*20 NAME - -C .. Executable Statements .. - NAME = 'CSWSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - WORK(1) = czero -C -C Check for identity matrix -C - IF(psb_toupper(DESCRT(1:1)).EQ.'D' .AND. - + psb_toupper(DESCRT(3:3)).EQ.'U') THEN - CALL CCOPY(M,B,ONE,C,ONE) - GOTO 9999 - ENDIF -C -C Switching on FIDT: proper sparse BLAS routine is selected -C according to data structure -C - IF (psb_toupper(FIDT(1:3)).EQ.'CSR') THEN -C -C T, IT1, IT2 ---> AR, JA, IA -C VAL, INDX, PNTR -C INFOT(*) not used -C - CALL CCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, - & IT2,B,LDB,BETA,C,LDC,WORK,LWORK) - ELSE IF ((psb_toupper(FIDT(1:3)).EQ.'JAD') - + .AND.(.FALSE.)) THEN -C -C .. JAD format not yet supported -C -C CALL CJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2,0, -C & B,LDB,BETA,C,LDC,WORK) -C - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - ENDIF - - RETURN - END - - diff --git a/base/serial/f77/dcsmm.f b/base/serial/f77/dcsmm.f deleted file mode 100644 index 482be0031..000000000 --- a/base/serial/f77/dcsmm.f +++ /dev/null @@ -1,376 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, -C INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C Purpose -C ======= -C -C Computing matrix-matrix product -C C <-- ALPHA PL A PR B + BETA C or -C C <-- ALPHA PL At PR B + BETA C -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C PL - INTEGER array of dimension (M) -C On entry PL specifies the row permutation of matrix A -C (PL(1) == 0 if no permutation). -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C PR - INTEGER array of dimension (K) -C On entry PR specifies the column permutation of matrix A -C (PR(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - DOUBLE PRECISION matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DCSMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = (LWORK for DxxxMM) + Pr*K*N + Pl*M*N -C where Pr (Pl) = 1 if right (left) permutation has to -C be performed, 0 otherwise. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Local Variables -C =============== -C -C LWORKM - INTEGER -C Minimum work area dimension for DCSMM -C -C LWORKB - INTEGER -C Work area dimension for matrix B in subroutine DLPUPD -C -C LWORKC - INTEGER -C Work area dimension for matrix C in subroutine DLPUPD -C -C LWORKS - INTEGER -C Work area dimension for subroutine DSWMM -C -C P - INTEGER -C Pointer to work area -C -C LP - LOGICAL -C LP is true if left permutation is required -C -C RP - LOGICAL -C RP is true if right permutation is required -C -C Notes -C ===== -C Some tests have shown that it is more efficient to divide the -C sparse matrix-dense matrix multiplication step and the dense -C matrix permutation step, and it is more efficient to put -C together the left permutation and update (C <- xxx + BETA C) -C steps. So, the sequence of operations is: -C Right permutation DLPUPD -C Matrix-Matrix product DSWMM -C Left permutation and update DLPUPD -C In order to avoid useless memory transfer, the above scheme is -C simplified according to whether right and left permutation have to -C be performed. If left permutation is not required, the update step -C is performed in the sparse matrix-dense matrix multiplication kernel. -C -C It is not possible to call this subroutine with LWORK=0 to get # -C the minimal value for LWORK. This functionality needs a better # -C connection with DxxxMM # -C -C - SUBROUTINE DCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, - & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE - -C .. Scalar Arguments .. - INTEGER M,N,K,LDB,LDC,LWORK, IERROR - CHARACTER TRANS - real(psb_dpk_) ALPHA,BETA -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*),PL(*),PR(*) - CHARACTER DESCRA*11, FIDA*5 - real(psb_dpk_) A(*),B(LDB,*),C(LDC,*),WORK(*) -C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P, ERR_ACT - LOGICAL LP, RP -C .. Local Array.. - INTEGER INT_VAL(5) - CHARACTER*20 NAME - CHARACTER*30 STRINGS(2) -C .. External Subroutines .. - EXTERNAL DSWMM, DLPUPD, DSCAL -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT - -C .. Executable Statements .. -C -C Check for argument errors -C - NAME = 'DCSMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (K.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 4 - INT_VAL(2) = K - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (LDB.LT.K) THEN - IERROR = 50 - INT_VAL(1) = 15 - INT_VAL(2) = 4 - INT_VAL(3) = LDB - INT_VAL(4) = K - ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 18 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - -C -C Inizializations -C - LP = PL(1).NE.0 - RP = PR(1).NE.0 - LWORKB = K*N - LWORKC = M*N - LWORKM = 0 - IF (RP) LWORKM = LWORKB - IF (LP) LWORKM = LWORKM + LWORKC - IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - LWORKS = LWORK - LWORKM - -C -C Check for M, N, K -C - IF(M.GT.0 .AND. N.GT.0 .AND. K.EQ.0) THEN -C -C Only C <-- BETA C required -C -C CALL DSCAL(M,BETA,C,IONE) - ELSE IF(M.LE.0 .OR. N.LE.0 .OR. K.LE.0) THEN - GOTO 9998 - ENDIF -C -C Switching on PR and PL -C - IF (LP .AND. RP) THEN -C -C Both right and left permutation required -C - P=LWORKB+1 - CALL DLPUPD(K,N,PR,B,LDB,DZERO,WORK,K) - CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,DZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) - LWORKS = IDINT(WORK(P+LWORKC)) - IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - CALL DLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) - ELSE IF(.NOT.LP .AND. RP) THEN -C -C Only right permutation required -C - P=LWORKB+1 - CALL DLPUPD(K,N,PR,B,LDB,DZERO,WORK,K) - CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) - LWORKS = IDINT(WORK(P)) - IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ELSE IF(.NOT.RP .AND. LP) THEN -C -C Only left permutation required -C - P=LWORKC+1 - CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,DZERO,WORK,M,WORK(P),LWORKS,IERROR) - LWORKS = IDINT(WORK(P)) - IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - CALL DLPUPD(M,N,PL,WORK,M,BETA,C,LDC) - ELSE IF(.NOT.RP .AND. .NOT.LP) THEN -C -C No permutations required -C - CALL DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,BETA,C,LDC,WORK,LWORKS,IERROR) - LWORKS = IDINT(WORK(1)) - IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - 9998 CONTINUE -C -C Return minimum workarea dimension -C - LWORKM = LWORKM + LWORKS - WORK(1) = DBLE(LWORKM) - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/dcsnmi.f b/base/serial/f77/dcsnmi.f deleted file mode 100644 index 20b534932..000000000 --- a/base/serial/f77/dcsnmi.f +++ /dev/null @@ -1,188 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C DOUBLE PRECISION FUNCTION DCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & -C & INFOA,IERROR) -C Purpose -C ======= -C -C Computing matrix infinity norm -C nrmi <-- ||A||infty or -C nrmi <-- ||At||infty -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Notes -C ===== -C - FUNCTION DCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,IERROR) - use psb_const_mod - use psb_string_mod - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) dcsnmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - real(psb_dpk_) A(*) -C .. Local Scalars.. - INTEGER ERR_ACT -C .. Local Array.. - INTEGER INT_VAL(5) -C .. External Subroutines .. - real(psb_dpk_) DCRNRMI, DJDNRMI, DCOONRMI - EXTERNAL DCRNRMI, DJDNRMI, DCOONRMI -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT - - CHARACTER*20 NAME -C .. Executable Statements .. -C -C Check for argument errors -C - IERROR = 0 - NAME = 'DCSNMI\0' - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Check for M, N, K -C - IF(M.LE.0 .OR. N.LE.0) THEN - DCSNMI = 0.D0 - GOTO 9999 - ENDIF - -C ... Compute infinity norm for matrix A ... - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN - DCSNMI = DCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN - DCSNMI = DJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN - DCSNMI = DCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - ENDIF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/dcsrp.f b/base/serial/f77/dcsrp.f deleted file mode 100644 index cce602437..000000000 --- a/base/serial/f77/dcsrp.f +++ /dev/null @@ -1,207 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DCSRP(TRANS,M,N,FIDA,DESCRA,IA1,IA2,INFOA, -C P,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Performing column permutation of a sparse matrix. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine will use -C matrix P or the transpose of P for the permutation as follows: -C TRANS = 'N' -> permute with matrix P -C TRANS = 'T' or 'C' -> permute the transpose of P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C DESCRA - CHARACTER*5 array of DIMENSION (10) -C On entry DESCRA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C On exit contain integer information on permuted matrix. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C On exit contain integer information on permuted matrix. -C -C INFOA - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the column permutation of matrix A -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DCSRP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C Work area. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK. -C LWORK must be greater than zero. -C On exit LWORK is the maximum between the initial value and -C the minimum value satisfying DCSRP memory requirements. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR = 4 error on dimension of vector WORK -C IERROR = 32 unknown flag TRANS -C IERROR = 64 LWORK <= 0 -C IERROR = 128 this data structure not yet considered -C -C Notes -C ===== -C It is not possible to call this subroutine with LWORK=0 to get -C the minimal value for LWORK. This functionality needs a better -C connection with DxxxMM -C -C - SUBROUTINE DCSRP(TRANS,M,N,FIDA,DESCRA,IA1,IA2,INFOA, - + P,WORK,LWORK,IERROR) - use psb_const_mod - use psb_error_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LWORK, M, N, IERROR - CHARACTER TRANS -C .. Local Scalars.. - INTEGER ERR_ACT -C .. Array Arguments .. - real(psb_dpk_) WORK(LWORK) - INTEGER IA1(*), IA2(*), INFOA(*), P(*), INT_VAL(5) - CHARACTER DESCRA*11, FIDA*5 -C .. External Subroutines .. - EXTERNAL DCSRRP - integer :: debug_level, debug_unit - CHARACTER*20 NAME -C -C .. Executable Statements .. -C -C -C Check on M, N, TRANS -C - NAME = 'DCSRP' - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LE.0) THEN - IERROR = 1 - ELSE IF(N.LE.0) THEN - IERROR = 3 - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = -1 - ENDIF -C -C Error handling -C - IF(IERROR.LT.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Check for M, N, P -C - IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN - GOTO 9999 - ENDIF -C -C Switching on FIDA -C - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN -C -C Permuting CSR structure -C - CALL DCSRRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name), - + ': Calling djadrp',m,p(1),lwork - CALL DJADRP(TRANS,M,N,DESCRA,IA1,IA2,P,WORK,LWORK) - ELSE -C -C This data structure not yet considered -C - IERROR = 4 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/dcsrws.f b/base/serial/f77/dcsrws.f deleted file mode 100644 index 6354c38d1..000000000 --- a/base/serial/f77/dcsrws.f +++ /dev/null @@ -1,184 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DCSRS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & -C & INFOA,ROWSUM,IERROR) -C Purpose -C ======= -C -C Computing sum of absolute values for rows of distributed matrix -C ROWSUM(IX) = ASUM(A(IX, 1..N)) -C IX = 1..M -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C ROWSUM - DOUBLE PRECISION array of dimension (*) -C On exit this vector contains the sum of absolute values -C of elements of a row (AMAX of row array). -C It is required that it has dimension: -C ROWSUM(M) if the subroutine in called with the 'N' option -C ROWSUM(N) in other cases ('T' or 'C' options). -C - SUBROUTINE DCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - use psb_string_mod - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - real(psb_dpk_) A(*), ROWSUM(*) -C .. Local Array.. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME,STRINGS(2) -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT -C .. Executable Statements .. -C -C Check for argument errors -C - IERROR = 0 - NAME = 'DCSRWS\0' - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IF(M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 - ENDIF - - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN - CALL DCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN - CALL DCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN - CALL DJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - strings(1) = fida//'\0' - ENDIF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/dcssm.f b/base/serial/f77/dcssm.f deleted file mode 100644 index cd3d60316..000000000 --- a/base/serial/f77/dcssm.f +++ /dev/null @@ -1,392 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DCSSM(TRANS,M,N,ALPHA,UNITD,D,PL,FIDT,DESCRT,T,IT1,IT2, -C INFOT,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Solving triangular systems of equations with multiple right-hand sides -C C <-- ALPHA PL D T-1 PR B + BETA C or -C C <-- ALPHA PL D T-t PR B + BETA C or -C C <-- ALPHA PL T-1 D PR B + BETA C or -C C <-- ALPHA PL T-t D PR B + BETA C -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine operates with -C matrix T or with the transpose of T as follows: -C TRANS = 'N' -> use matrix T -C TRANS = 'T' or 'C' -> use T' (transpose of matrix T) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows and columns of matrix Ty -C and number of rows of matrices B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrices B and C -C (number of right-hand sides). -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - DOUBLE PRECISION array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C PL - INTEGER array of dimension (M) -C On entry PL specifies the row permutation of matrix T -C (PL(1) == 0 if no permutation). -C Unchanged on exit. -C -C FIDT - CHARACTER*5 -C On entry FIDT defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRT - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRT describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C -C T - DOUBLE PRECISION array of DIMENSION (*) -C On entry T specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IT1 - INTEGER array of dimension (*) -C On entry IT1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IT2 - INTEGER array of dimension (*) -C On entry IT2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOT - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C PR - INTEGER array of dimension (M) -C On entry PR specifies the column permutation of matrix T -C (PR(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of dimension (LDB,*) -C On entry: matrix of right-hand sides -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION array of dimension (LDC,*) -C On exit: solutions of triangular systems -C -C LDC - INTEGER -C On entry: leading dimension of C. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DCSSM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = (LWORK for DxxxSM) + Pr*M*N + Pl*M*N -C where Pr íPlù = 1 if right íleftù permutation has to -C be performed, 0 otherwise. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Local Variables -C =============== -C -C LWORKM - INTEGER -C Minimum work area dimension for DCSSM -C -C LWORKB - INTEGER -C Work area dimension for matrices B, C in subroutines DLPUPD -C -C LWORKS - INTEGER -C Work area dimension for subroutine DSWSM -C -C P - INTEGER -C Pointer to work area -C -C LP - LOGICAL -C LP is true if left permutation is required -C -C RP - LOGICAL -C RP is true if right permutation is required -C -C Notes -C ===== -C Some tests have shown that it is more efficient to divide the -C sparse matrix-dense matrix multiplication step and the dense -C matrix permutation and update (C <- xxx + BETA C) step. -C So, the sequence of operations is: -C Right permutation DLPUPD -C Matrix-Matrix product DSWSM -C Left permutation and update DLPUPD -C In order to avoid useless memory transfer, the above scheme is -C simplified according to whether right and left permutation -C have to be performed. -C -C - SUBROUTINE DCSSM(TRANS,M,N,ALPHA,UNITD,D, - + PL,FIDT,DESCRT,T,IT1,IT2,INFOT,PR, - + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C .. Scalar Arguments .. - use psb_const_mod - use psb_error_mod - use psb_string_mod - IMPLICIT NONE - real(psb_dpk_) ALPHA, BETA - INTEGER N, LDB, LDC, M, LWORK, IERROR - CHARACTER UNITD, TRANS -C .. Array Arguments .. - real(psb_dpk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IT1(*), IT2(*), INFOT(*), PL(*), PR(*) - CHARACTER DESCRT*11, FIDT*5 -C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKS, P, ERR_ACT - LOGICAL LP, RP -C .. Local Array.. - INTEGER INT_VAL(5) - CHARACTER*30 STRINGS(2) - CHARACTER NAME*20 - integer :: debug_level, debug_unit - - -C .. External Subroutines .. - EXTERNAL DSWSM, DLPUPD -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT -C .. Executable Statements .. -C -C Check for argument errors -C - IERROR = 0 - NAME = 'DCSSM' - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (psb_toupper(UNITD).NE.'U' .AND. - + psb_toupper(UNITD).NE.'L' .AND. - + psb_toupper(UNITD).NE.'R' .AND. - + psb_toupper(UNITD).NE.'B') THEN - IERROR = 40 - INT_VAL(1) = 5 - STRINGS(1) = UNITD//'\0' - ELSE IF (LDB.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 16 - INT_VAL(2) = 2 - INT_VAL(3) = LDB - INT_VAL(4) = M - ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 19 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Inizializations -C - LP = PL(1).NE.0 - RP = PR(1).NE.0 - LWORKB = M*N - LWORKM = 0 - IF (RP) LWORKM = LWORKB - IF (LP) LWORKM = LWORKM + LWORKB - P = LWORKB+1 - IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 21 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - LWORKS = LWORK - LWORKM - -C Check for M, N -C - IF (M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 - ENDIF -C -C Switching on xP -C - IF (LP .AND. RP) THEN -C -C Both right and left permutations required -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': RP LP ',m,n,ierror - - CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,DZERO,WORK(P),M,WORK(P+LWORKB),LWORK,IERROR) - LWORKS = IDINT(WORK(P+LWORKB)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL DLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) - ELSE IF(.NOT.LP .AND. RP) THEN -C -C Only right permutation required -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': RP NLP ',m,n,ierror - - CALL DLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,DZERO,C,LDC,WORK(P),LWORK,IERROR) - LWORKS = IDINT(WORK(P)) - IF(IERROR .NE. 0) THEN - NAME = 'DCSSM\0' - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE IF(.NOT.RP .AND. LP) THEN -C -C Only left permutation required -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NRP LP ',m,n,ierror - CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,WORK,M,WORK(P),LWORK,IERROR) - LWORKS = IDINT(WORK(P)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL DLPUPD(M,N,PL,WORK,M,BETA,C,LDC) - ELSE IF(.NOT.RP .AND. .NOT.LP) THEN -C -C Only triangular systems solver required -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NRP NLP ',m,n,ierror - CALL DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - LWORKS = IDINT(WORK(1)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDIF - -C -C Return minimum workarea dimension -C - LWORKM = LWORKM + LWORKS - WORK(1) = DBLE(LWORKM) - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/dgelp.f b/base/serial/f77/dgelp.f deleted file mode 100644 index bf3cdf0e7..000000000 --- a/base/serial/f77/dgelp.f +++ /dev/null @@ -1,204 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C Computing -C B <-- op(P) B -C where op(P) is permutation matrix P or its transpose. -C Notice: when B is a diagonal matrix and it is stored as -C a vector whose entry i is B(i,i), this routine computes -C B <-- P B P(-1) -C where P(-1) is the inverse of P. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whetherif the routine operates with -C matrix P or with the transpose of P as follows: -C TRANS = 'N' -> use matrix P -C TRANS = 'T' OR 'C' -> use the transpose of matrix P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix B. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B. -C Unchanged on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the row permutation of matrix B -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of dimension (LDB,*) -C On entry: dense matrix. -C On exit: permuted matrix. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DGELP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = M -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C - SUBROUTINE DGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LDB, M, N, LWORK, IERROR - CHARACTER TRANS -C .. Array Arguments .. - real(psb_dpk_) B(LDB,*), WORK(*) - INTEGER P(*) -C .. Local Scalars .. - INTEGER I, J, ERR_ACT - logical istran,isnotran -C .. Local Arrays.. - INTEGER INT_VAL -C .. Intrinsic Functions .. - INTRINSIC DBLE - logical psb_lsame - external psb_lsame - - character*20 name -c -C .. Executable Statements .. -C -C -C Check on M, N, LDB, LWORK, TRANS -C - NAME = 'DGELP\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - isnotran = psb_lsame(psb_toupper(trans),'N') - istran = psb_lsame(psb_toupper(trans),'T') .or. - + psb_lsame(psb_toupper(trans),'C') - IF (M.LT.0) THEN - IERROR = 7 - ELSE IF(N.LT.0) THEN - IERROR = 3 - ELSE IF(M.GT.LDB) THEN - IERROR = -6 - ELSE IF (LWORK.LT.M) THEN - IF (LWORK.EQ.0) THEN -C -C Return minimum LWORK -C - IERROR = 8 - WORK(1) = DBLE(M) - GOTO 9998 - ELSE IF(LWORK.NE.0) THEN - IERROR = -8 - ENDIF - ELSE IF (.not.istran.and..not.isnotran) THEN - IERROR = -1 - ENDIF -C -C Error handling -C - IF(IERROR.LT.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Check for M, N, P -C - IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Switch on TRANS -C - IF (isnotran) THEN -C -C Permuting with P -C - DO 60 J = 1, N - DO 20 I = 1, M - WORK(I) = B(P(I),J) - 20 CONTINUE - DO 40 I = 1, M - B(I,J) = WORK(I) - 40 CONTINUE - 60 CONTINUE - ELSE IF (istran) THEN -C -C Permuting with the transpose of P. -C - DO 160 J = 1, N - DO 120 I = 1, M - WORK(P(I)) = B(I,J) - 120 CONTINUE - DO 140 I = 1, M - B(I,J) = WORK(I) - 140 CONTINUE - 160 CONTINUE - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/dlpupd.f b/base/serial/f77/dlpupd.f deleted file mode 100644 index 4ab7b4771..000000000 --- a/base/serial/f77/dlpupd.f +++ /dev/null @@ -1,116 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Subroutine DLPUPD(M,N,PERM,B,LDB,BETA,C,LDC,IERROR) -C Purpose -C ======= -C -C Computing C <-- PERM B + BETA C -C where PERM is a permutation matrix. -C -C Parameters -C ========== -C -C M - INTEGER -C On entry M specifies the number of rows of matrices -C B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry N specifies the number of columns of matrices -C B and C. -C Unchanged on exit. -C -C PERM - INTEGER array of dimension (N) -C On entry PERM specifies the values of a permutation matrix. -C Unchanged on exit. -C -C B - DOUBLE PRECISION matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry LDB holds the value of the leading dimension of B -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated as shown above. -C -C LDC - INTEGER -C On entry LDC holds the value of the leading dimension of C -C Unchanged on exit. -C -C Note -C ==== -C All checks on argument are performed in the calling routines. -C -C - SUBROUTINE DLPUPD(M,N,PERM,B,LDB,BETA,C,LDC) - use psb_const_mod -C .. Scalar Arguments .. - INTEGER M, N, LDB, LDC - real(psb_dpk_) BETA -C .. Array Arguments .. - INTEGER PERM(*) - real(psb_dpk_) B(LDB,*), C(LDC,*) -C .. Local Scalars .. - INTEGER I,J -C -C .. Executable Statements .. -C -C Switching on BETA -C - IF (BETA.NE.0.D0) THEN -C -C Performing left permutation and update -C - DO 40 J = 1, N - DO 30 I = 1, M - C(I,J) = B(PERM(I),J) + BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - ELSE IF(BETA.EQ.0.D0) THEN -C -C Performing right or left permutation -C - DO 160 J = 1, N - DO 150 I = 1, M - C(I,J) = B(PERM(I),J) - 150 CONTINUE - 160 CONTINUE - ENDIF - RETURN - END diff --git a/base/serial/f77/dswmm.f b/base/serial/f77/dswmm.f deleted file mode 100644 index a5ee57168..000000000 --- a/base/serial/f77/dswmm.f +++ /dev/null @@ -1,212 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, -C INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C Purpose -C ======= -C -C Computing C <-- ALPHA A B + BETA C or -C C <-- ALPHA At B + BETA C -C Called by DCSMM -C Actual computing performed by sparse Toolkit kernels. -C This routine selects the proper kernel for each -C data structure. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - DOUBLE PRECISION matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSWMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Note -C ==== -C All checks on argument are performed in the calling routine. -C -C - SUBROUTINE DSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, & - & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - INTEGER M,N,K,LDB,LDC,LWORK,IERROR - CHARACTER TRANS - real(psb_dpk_) ALPHA,BETA -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*), INT_VAL(5) - CHARACTER DESCRA*11, FIDA*5 - real(psb_dpk_) A(*),B(LDB,*),C(LDC,*),WORK(*) -C .. External Subroutines .. - EXTERNAL DCSRMM - - CHARACTER*20 NAME - -C .. Executable Statements .. -C - - NAME = 'DSWMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - WORK(1) = dzero -C Switching on FIDA: proper sparse BLAS routine is selected -C according to data structure -C - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN -C -C A, IA1, IA2 ---> AR, JA, IA -C VAL, INDX, PNTR -C INFOA(*) not used - - CALL DCSRMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - + IA2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN -C -C INFOA(*) not used -C - CALL DJADMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - + IA2,B,LDB,BETA,C,LDC,WORK,IERROR) - - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN -C -C - CALL DCOOMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - + IA2,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/dswsm.f b/base/serial/f77/dswsm.f deleted file mode 100644 index b88a42c0d..000000000 --- a/base/serial/f77/dswsm.f +++ /dev/null @@ -1,244 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, -C INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Solving triangular systems of equations with multiple right-hand sides -C C <-- ALPHA D T-1 B + BETA C or -C C <-- ALPHA D T-t B + BETA C or -C C <-- ALPHA T-1 D B + BETA C or -C C <-- ALPHA T-t D B + BETA C -C Actual computing performed by sparse Toolkit kernels. -C This routine selects the proper kernel for each -C data structure. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine operates with -C matrix T or with the transpose of T as follows: -C TRANS = 'N' -> use matrix T -C TRANS = 'T' or 'C' -> use T' (transpose of matrix T) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows and columns of matrix T -C and number of rows of matrices B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrices B and C -C (number of right-hand sides). -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - DOUBLE PRECISION array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C FIDT - CHARACTER*5 -C On entry FIDT defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRT - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRT describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C -C T - DOUBLE PRECISION array of DIMENSION (*) -C On entry T specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IT1 - INTEGER array of dimension (*) -C On entry IT1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IT2 - INTEGER array of dimension (*) -C On entry IT2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOT - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - DOUBLE PRECISION array of dimension (LDB,*) -C On entry: matrix of right-hand sides -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION array of dimension (LDC,*) -C On exit: solutions of triangular systems -C -C LDC - INTEGER -C On entry: leading dimension of C. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSWSM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Note -C ==== -C All checks on argument are performed in the calling routine. -C -C - SUBROUTINE DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_const_mod - use psb_error_mod - use psb_string_mod - implicit none -C .. Scalar Arguments .. - INTEGER M, N, LDB, LDC, LWORK, IERROR - CHARACTER UNITD, TRANS - real(psb_dpk_) ALPHA, BETA -C .. Array Arguments .. - INTEGER IT1(*), IT2(*), INFOT(*) - CHARACTER DESCRT*11, FIDT*5 - real(psb_dpk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) -C .. Local Scalars .. - INTEGER ONE -C .. Parameters .. - PARAMETER (ONE=1) -C .. External Subroutines .. - EXTERNAL DCSRSM, DCOPY - integer debug_level, debug_unit, err_act, int_val(5) - CHARACTER*20 NAME - -C .. Executable Statements .. - - NAME = 'DSWSM' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - WORK(1) = dzero - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - -C -C Check for identity matrix -C - IF(psb_toupper(DESCRT(1:1)).EQ.'D' .AND. - + psb_toupper(DESCRT(3:3)).EQ.'U') THEN - CALL DCOPY(M,B,ONE,C,ONE) - GOTO 9998 - ENDIF - - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': entry ',m,n,ierror,' ',unitd -C -C Switching on FIDT: proper sparse BLAS routine is selected -C according to data structure -C - IF (psb_toupper(FIDT(1:3)).EQ.'CSR') THEN -C -C T, IT1, IT2 ---> AR, JA, IA -C VAL, INDX, PNTR -C INFOT(*) not used -C - CALL DCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, - & IT2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - ELSE IF (psb_toupper(FIDT(1:3)).EQ.'JAD') THEN - - CALL DJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2, - + 0,B,LDB,BETA,C,LDC,WORK) - - ELSE IF (psb_toupper(FIDT(1:3)).EQ.'COO') THEN - - CALL DCOOSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1,IT2,INFOT, - + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/scsmm.f b/base/serial/f77/scsmm.f deleted file mode 100644 index 4489a9045..000000000 --- a/base/serial/f77/scsmm.f +++ /dev/null @@ -1,371 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE SCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, -C INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C Purpose -C ======= -C -C Computing matrix-matrix product -C C <-- ALPHA PL A PR B + BETA C or -C C <-- ALPHA PL At PR B + BETA C -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C PL - INTEGER array of dimension (M) -C On entry PL specifies the row permutation of matrix A -C (PL(1) == 0 if no permutation). -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C PR - INTEGER array of dimension (K) -C On entry PR specifies the column permutation of matrix A -C (PR(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - DOUBLE PRECISION matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying SCSMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = (LWORK for DxxxMM) + Pr*K*N + Pl*M*N -C where Pr (Pl) = 1 if right (left) permutation has to -C be performed, 0 otherwise. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Local Variables -C =============== -C -C LWORKM - INTEGER -C Minimum work area dimension for SCSMM -C -C LWORKB - INTEGER -C Work area dimension for matrix B in subroutine DLPUPD -C -C LWORKC - INTEGER -C Work area dimension for matrix C in subroutine DLPUPD -C -C LWORKS - INTEGER -C Work area dimension for subroutine DSWMM -C -C P - INTEGER -C Pointer to work area -C -C LP - LOGICAL -C LP is true if left permutation is required -C -C RP - LOGICAL -C RP is true if right permutation is required -C -C Notes -C ===== -C Some tests have shown that it is more efficient to divide the -C sparse matrix-dense matrix multiplication step and the dense -C matrix permutation step, and it is more efficient to put -C together the left permutation and update (C <- xxx + BETA C) -C steps. So, the sequence of operations is: -C Right permutation DLPUPD -C Matrix-Matrix product DSWMM -C Left permutation and update DLPUPD -C In order to avoid useless memory transfer, the above scheme is -C simplified according to whether right and left permutation have to -C be performed. If left permutation is not required, the update step -C is performed in the sparse matrix-dense matrix multiplication kernel. -C -C It is not possible to call this subroutine with LWORK=0 to get # -C the minimal value for LWORK. This functionality needs a better # -C connection with DxxxMM # -C -C - SUBROUTINE SCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, - & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - IMPLICIT NONE - -C .. Scalar Arguments .. - INTEGER M,N,K,LDB,LDC,LWORK, IERROR - CHARACTER TRANS - real(psb_spk_) ALPHA,BETA -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*),PL(*),PR(*) - CHARACTER DESCRA*11, FIDA*5 - real(psb_spk_) A(*),B(LDB,*),C(LDC,*),WORK(*) -C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P, ERR_ACT - LOGICAL LP, RP -C .. Local Array.. - INTEGER INT_VAL(5) - CHARACTER*20 NAME - CHARACTER*30 STRINGS(2) -C .. External Subroutines .. - EXTERNAL SSWMM, SLPUPD, SSCAL - -C .. Executable Statements .. -C -C Check for argument errors -C - NAME = 'SCSMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (K.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 4 - INT_VAL(2) = K - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (LDB.LT.K) THEN - IERROR = 50 - INT_VAL(1) = 15 - INT_VAL(2) = 4 - INT_VAL(3) = LDB - INT_VAL(4) = K - ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 18 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - -C -C Inizializations -C - LP = PL(1).NE.0 - RP = PR(1).NE.0 - LWORKB = K*N - LWORKC = M*N - LWORKM = 0 - IF (RP) LWORKM = LWORKB - IF (LP) LWORKM = LWORKM + LWORKC - IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - LWORKS = LWORK - LWORKM - -C -C Check for M, N, K -C - IF(M.GT.0 .AND. N.GT.0 .AND. K.EQ.0) THEN -C -C Only C <-- BETA C required -C -C CALL SSCAL(M,BETA,C,IONE) - ELSE IF(M.LE.0 .OR. N.LE.0 .OR. K.LE.0) THEN - GOTO 9998 - ENDIF -C -C Switching on PR and PL -C - IF (LP .AND. RP) THEN -C -C Both right and left permutation required -C - P=LWORKB+1 - CALL SLPUPD(K,N,PR,B,LDB,SZERO,WORK,K) - CALL SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,SZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) - LWORKS = INT(WORK(P+LWORKC)) - IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - CALL SLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) - ELSE IF(.NOT.LP .AND. RP) THEN -C -C Only right permutation required -C - P=LWORKB+1 - CALL SLPUPD(K,N,PR,B,LDB,SZERO,WORK,K) - CALL SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) - LWORKS = INT(WORK(P)) - IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ELSE IF(.NOT.RP .AND. LP) THEN -C -C Only left permutation required -C - P=LWORKC+1 - CALL SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,SZERO,WORK,M,WORK(P),LWORKS,IERROR) - LWORKS = INT(WORK(P)) - IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - CALL SLPUPD(M,N,PL,WORK,M,BETA,C,LDC) - ELSE IF(.NOT.RP .AND. .NOT.LP) THEN -C -C No permutations required -C - CALL SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,BETA,C,LDC,WORK,LWORKS,IERROR) - LWORKS = INT(WORK(1)) - IF(IERROR .NE. 0) THEN - IERROR=4011 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - 9998 CONTINUE -C -C Return minimum workarea dimension -C - LWORKM = LWORKM + LWORKS - WORK(1) = REAL(LWORKM) - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/scsnmi.f b/base/serial/f77/scsnmi.f deleted file mode 100644 index 756eedfd1..000000000 --- a/base/serial/f77/scsnmi.f +++ /dev/null @@ -1,185 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C DOUBLE PRECISION FUNCTION DCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & -C & INFOA,IERROR) -C Purpose -C ======= -C -C Computing matrix infinity norm -C nrmi <-- ||A||infty or -C nrmi <-- ||At||infty -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Notes -C ===== -C - FUNCTION SCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE - real(psb_spk_) scsnmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - real(psb_spk_) A(*) -C .. Local Scalars.. - INTEGER ERR_ACT -C .. Local Array.. - INTEGER INT_VAL(5) -C .. External Subroutines .. - real(psb_spk_) SCRNRMI, SJDNRMI, SCOONRMI - EXTERNAL SCRNRMI, SJDNRMI, SCOONRMI - - CHARACTER*20 NAME -C .. Executable Statements .. -C -C Check for argument errors -C - IERROR = 0 - NAME = 'SCSNMI\0' - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (TRANS.NE.'T' .AND. TRANS.NE.'N' .AND. TRANS.NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Check for M, N, K -C - IF(M.LE.0 .OR. N.LE.0) THEN - SCSNMI = SZERO - GOTO 9999 - ENDIF - -C ... Compute infinity norm for matrix A ... - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN - SCSNMI = SCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN - SCSNMI = SJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN - SCSNMI = SCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - ENDIF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/scsrws.f b/base/serial/f77/scsrws.f deleted file mode 100644 index 18b58d432..000000000 --- a/base/serial/f77/scsrws.f +++ /dev/null @@ -1,183 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DCSRS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & -C & INFOA,ROWSUM,IERROR) -C Purpose -C ======= -C -C Computing sum of absolute values for rows of distributed matrix -C ROWSUM(IX) = ASUM(A(IX, 1..N)) -C IX = 1..M -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C ROWSUM - DOUBLE PRECISION array of dimension (*) -C On exit this vector contains the sum of absolute values -C of elements of a row (AMAX of row array). -C It is required that it has dimension: -C ROWSUM(M) if the subroutine in called with the 'N' option -C ROWSUM(N) in other cases ('T' or 'C' options). -C - SUBROUTINE SCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - real(psb_spk_) A(*), ROWSUM(*) -C .. Local Array.. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME,STRINGS(2) -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT -C .. Executable Statements .. -C -C Check for argument errors -C - IERROR = 0 - NAME = 'SCSRWS\0' - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IF(M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 - ENDIF - - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN - CALL SCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN - CALL SCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN - CALL SJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - strings(1) = fida//'\0' - ENDIF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/scssm.f b/base/serial/f77/scssm.f deleted file mode 100644 index 6fa4342cc..000000000 --- a/base/serial/f77/scssm.f +++ /dev/null @@ -1,387 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DCSSM(TRANS,M,N,ALPHA,UNITD,D,PL,FIDT,DESCRT,T,IT1,IT2, -C INFOT,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Solving triangular systems of equations with multiple right-hand sides -C C <-- ALPHA PL D T-1 PR B + BETA C or -C C <-- ALPHA PL D T-t PR B + BETA C or -C C <-- ALPHA PL T-1 D PR B + BETA C or -C C <-- ALPHA PL T-t D PR B + BETA C -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine operates with -C matrix T or with the transpose of T as follows: -C TRANS = 'N' -> use matrix T -C TRANS = 'T' or 'C' -> use T' (transpose of matrix T) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows and columns of matrix Ty -C and number of rows of matrices B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrices B and C -C (number of right-hand sides). -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - DOUBLE PRECISION array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C PL - INTEGER array of dimension (M) -C On entry PL specifies the row permutation of matrix T -C (PL(1) == 0 if no permutation). -C Unchanged on exit. -C -C FIDT - CHARACTER*5 -C On entry FIDT defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRT - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRT describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C -C T - DOUBLE PRECISION array of DIMENSION (*) -C On entry T specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IT1 - INTEGER array of dimension (*) -C On entry IT1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IT2 - INTEGER array of dimension (*) -C On entry IT2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOT - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C PR - INTEGER array of dimension (M) -C On entry PR specifies the column permutation of matrix T -C (PR(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of dimension (LDB,*) -C On entry: matrix of right-hand sides -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION array of dimension (LDC,*) -C On exit: solutions of triangular systems -C -C LDC - INTEGER -C On entry: leading dimension of C. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DCSSM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = (LWORK for DxxxSM) + Pr*M*N + Pl*M*N -C where Pr íPlù = 1 if right íleftù permutation has to -C be performed, 0 otherwise. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Local Variables -C =============== -C -C LWORKM - INTEGER -C Minimum work area dimension for DCSSM -C -C LWORKB - INTEGER -C Work area dimension for matrices B, C in subroutines DLPUPD -C -C LWORKS - INTEGER -C Work area dimension for subroutine DSWSM -C -C P - INTEGER -C Pointer to work area -C -C LP - LOGICAL -C LP is true if left permutation is required -C -C RP - LOGICAL -C RP is true if right permutation is required -C -C Notes -C ===== -C Some tests have shown that it is more efficient to divide the -C sparse matrix-dense matrix multiplication step and the dense -C matrix permutation and update (C <- xxx + BETA C) step. -C So, the sequence of operations is: -C Right permutation DLPUPD -C Matrix-Matrix product DSWSM -C Left permutation and update DLPUPD -C In order to avoid useless memory transfer, the above scheme is -C simplified according to whether right and left permutation -C have to be performed. -C -C - SUBROUTINE SCSSM(TRANS,M,N,ALPHA,UNITD,D, - + PL,FIDT,DESCRT,T,IT1,IT2,INFOT,PR, - + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C .. Scalar Arguments .. - use psb_const_mod - use psb_error_mod - use psb_string_mod - IMPLICIT NONE - real(psb_spk_) ALPHA, BETA - INTEGER N, LDB, LDC, M, LWORK, IERROR - CHARACTER UNITD, TRANS -C .. Array Arguments .. - real(psb_spk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IT1(*), IT2(*), INFOT(*), PL(*), PR(*) - CHARACTER DESCRT*11, FIDT*5 -C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKS, P, ERR_ACT - LOGICAL LP, RP -C .. Local Array.. - INTEGER INT_VAL(5) - CHARACTER*30 STRINGS(2) - CHARACTER NAME*20 - integer :: debug_level, debug_unit - - -C -C Check for argument errors -C - IERROR = 0 - NAME = 'DCSSM' - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (psb_toupper(UNITD).NE.'U' .AND. - + psb_toupper(UNITD).NE.'L' .AND. - + psb_toupper(UNITD).NE.'R' .AND. - + psb_toupper(UNITD).NE.'B') THEN - IERROR = 40 - INT_VAL(1) = 5 - STRINGS(1) = UNITD//'\0' - ELSE IF (LDB.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 16 - INT_VAL(2) = 2 - INT_VAL(3) = LDB - INT_VAL(4) = M - ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 19 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Inizializations -C - LP = PL(1).NE.0 - RP = PR(1).NE.0 - LWORKB = M*N - LWORKM = 0 - IF (RP) LWORKM = LWORKB - IF (LP) LWORKM = LWORKM + LWORKB - P = LWORKB+1 - IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 21 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - LWORKS = LWORK - LWORKM - -C Check for M, N -C - IF (M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 - ENDIF -C -C Switching on xP -C - IF (LP .AND. RP) THEN -C -C Both right and left permutations required -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': RP LP ',m,n,ierror - - CALL SLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,SZERO,WORK(P),M,WORK(P+LWORKB),LWORK,IERROR) - LWORKS = INT(WORK(P+LWORKB)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL SLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) - ELSE IF(.NOT.LP .AND. RP) THEN -C -C Only right permutation required -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': RP NLP ',m,n,ierror - - CALL SLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,SZERO,C,LDC,WORK(P),LWORK,IERROR) - LWORKS = INT(WORK(P)) - IF(IERROR .NE. 0) THEN - NAME = 'DCSSM\0' - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE IF(.NOT.RP .AND. LP) THEN -C -C Only left permutation required -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NRP LP ',m,n,ierror - CALL SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,WORK,M,WORK(P),LWORK,IERROR) - LWORKS = INT(WORK(P)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL SLPUPD(M,N,PL,WORK,M,BETA,C,LDC) - ELSE IF(.NOT.RP .AND. .NOT.LP) THEN -C -C Only triangular systems solver required -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': NRP NLP ',m,n,ierror - CALL SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - LWORKS = INT(WORK(1)) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDIF - -C -C Return minimum workarea dimension -C - LWORKM = LWORKM + LWORKS - WORK(1) = REAL(LWORKM) - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/sgelp.f b/base/serial/f77/sgelp.f deleted file mode 100644 index d52ac1b74..000000000 --- a/base/serial/f77/sgelp.f +++ /dev/null @@ -1,204 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C Computing -C B <-- op(P) B -C where op(P) is permutation matrix P or its transpose. -C Notice: when B is a diagonal matrix and it is stored as -C a vector whose entry i is B(i,i), this routine computes -C B <-- P B P(-1) -C where P(-1) is the inverse of P. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whetherif the routine operates with -C matrix P or with the transpose of P as follows: -C TRANS = 'N' -> use matrix P -C TRANS = 'T' OR 'C' -> use the transpose of matrix P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix B. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B. -C Unchanged on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the row permutation of matrix B -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of dimension (LDB,*) -C On entry: dense matrix. -C On exit: permuted matrix. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DGELP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = M -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C - SUBROUTINE SGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LDB, M, N, LWORK, IERROR - CHARACTER TRANS -C .. Array Arguments .. - real(psb_spk_) B(LDB,*), WORK(*) - INTEGER P(*) -C .. Local Scalars .. - INTEGER I, J, ERR_ACT - logical istran,isnotran -C .. Local Arrays.. - INTEGER INT_VAL -C .. Intrinsic Functions .. - INTRINSIC DBLE - logical psb_lsame - external psb_lsame - - character*20 name -c -C .. Executable Statements .. -C -C -C Check on M, N, LDB, LWORK, TRANS -C - NAME = 'SGELP\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - isnotran = psb_lsame(psb_toupper(trans),'N') - istran = psb_lsame(psb_toupper(trans),'T') .or. - + psb_lsame(psb_toupper(trans),'C') - IF (M.LT.0) THEN - IERROR = 7 - ELSE IF(N.LT.0) THEN - IERROR = 3 - ELSE IF(M.GT.LDB) THEN - IERROR = -6 - ELSE IF (LWORK.LT.M) THEN - IF (LWORK.EQ.0) THEN -C -C Return minimum LWORK -C - IERROR = 8 - WORK(1) = REAL(M) - GOTO 9998 - ELSE IF(LWORK.NE.0) THEN - IERROR = -8 - ENDIF - ELSE IF (.not.istran.and..not.isnotran) THEN - IERROR = -1 - ENDIF -C -C Error handling -C - IF(IERROR.LT.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Check for M, N, P -C - IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Switch on TRANS -C - IF (isnotran) THEN -C -C Permuting with P -C - DO 60 J = 1, N - DO 20 I = 1, M - WORK(I) = B(P(I),J) - 20 CONTINUE - DO 40 I = 1, M - B(I,J) = WORK(I) - 40 CONTINUE - 60 CONTINUE - ELSE IF (istran) THEN -C -C Permuting with the transpose of P. -C - DO 160 J = 1, N - DO 120 I = 1, M - WORK(P(I)) = B(I,J) - 120 CONTINUE - DO 140 I = 1, M - B(I,J) = WORK(I) - 140 CONTINUE - 160 CONTINUE - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/slpupd.f b/base/serial/f77/slpupd.f deleted file mode 100644 index a688273ea..000000000 --- a/base/serial/f77/slpupd.f +++ /dev/null @@ -1,116 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Subroutine SLPUPD(M,N,PERM,B,LDB,BETA,C,LDC,IERROR) -C Purpose -C ======= -C -C Computing C <-- PERM B + BETA C -C where PERM is a permutation matrix. -C -C Parameters -C ========== -C -C M - INTEGER -C On entry M specifies the number of rows of matrices -C B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry N specifies the number of columns of matrices -C B and C. -C Unchanged on exit. -C -C PERM - INTEGER array of dimension (N) -C On entry PERM specifies the values of a permutation matrix. -C Unchanged on exit. -C -C B - DOUBLE PRECISION matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry LDB holds the value of the leading dimension of B -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated as shown above. -C -C LDC - INTEGER -C On entry LDC holds the value of the leading dimension of C -C Unchanged on exit. -C -C Note -C ==== -C All checks on argument are performed in the calling routines. -C -C - SUBROUTINE SLPUPD(M,N,PERM,B,LDB,BETA,C,LDC) - use psb_const_mod -C .. Scalar Arguments .. - INTEGER M, N, LDB, LDC - real(psb_spk_) BETA -C .. Array Arguments .. - INTEGER PERM(*) - real(psb_spk_) B(LDB,*), C(LDC,*) -C .. Local Scalars .. - INTEGER I,J -C -C .. Executable Statements .. -C -C Switching on BETA -C - IF (BETA.NE.SZERO) THEN -C -C Performing left permutation and update -C - DO 40 J = 1, N - DO 30 I = 1, M - C(I,J) = B(PERM(I),J) + BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - ELSE IF(BETA.EQ.SZERO) THEN -C -C Performing right or left permutation -C - DO 160 J = 1, N - DO 150 I = 1, M - C(I,J) = B(PERM(I),J) - 150 CONTINUE - 160 CONTINUE - ENDIF - RETURN - END diff --git a/base/serial/f77/sswmm.f b/base/serial/f77/sswmm.f deleted file mode 100644 index 6a3ef17df..000000000 --- a/base/serial/f77/sswmm.f +++ /dev/null @@ -1,211 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, -C INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C Purpose -C ======= -C -C Computing C <-- ALPHA A B + BETA C or -C C <-- ALPHA At B + BETA C -C Called by DCSMM -C Actual computing performed by sparse Toolkit kernels. -C This routine selects the proper kernel for each -C data structure. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - DOUBLE PRECISION matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSWMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Note -C ==== -C All checks on argument are performed in the calling routine. -C -C - SUBROUTINE SSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, & - & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod -C .. Scalar Arguments .. - INTEGER M,N,K,LDB,LDC,LWORK,IERROR - CHARACTER TRANS - real(psb_spk_) ALPHA,BETA -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*), INT_VAL(5) - CHARACTER DESCRA*11, FIDA*5 - real(psb_spk_) A(*),B(LDB,*),C(LDC,*),WORK(*) -C .. External Subroutines .. - EXTERNAL SCSRMM - - CHARACTER*20 NAME - -C .. Executable Statements .. -C - - NAME = 'DSWMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - WORK(1) = szero -C Switching on FIDA: proper sparse BLAS routine is selected -C according to data structure -C - IF (FIDA(1:3).EQ.'CSR') THEN -C -C A, IA1, IA2 ---> AR, JA, IA -C VAL, INDX, PNTR -C INFOA(*) not used - - CALL SCSRMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - + IA2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - - ELSE IF (FIDA(1:3).EQ.'JAD') THEN -C -C INFOA(*) not used -C - CALL SJADMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - + IA2,B,LDB,BETA,C,LDC,WORK,IERROR) - - ELSE IF (FIDA(1:3).EQ.'COO') THEN -C -C - CALL SCOOMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - + IA2,INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/sswsm.f b/base/serial/f77/sswsm.f deleted file mode 100644 index f43590ee6..000000000 --- a/base/serial/f77/sswsm.f +++ /dev/null @@ -1,243 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, -C INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Solving triangular systems of equations with multiple right-hand sides -C C <-- ALPHA D T-1 B + BETA C or -C C <-- ALPHA D T-t B + BETA C or -C C <-- ALPHA T-1 D B + BETA C or -C C <-- ALPHA T-t D B + BETA C -C Actual computing performed by sparse Toolkit kernels. -C This routine selects the proper kernel for each -C data structure. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine operates with -C matrix T or with the transpose of T as follows: -C TRANS = 'N' -> use matrix T -C TRANS = 'T' or 'C' -> use T' (transpose of matrix T) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows and columns of matrix T -C and number of rows of matrices B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrices B and C -C (number of right-hand sides). -C Unchanged on exit. -C -C ALPHA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - DOUBLE PRECISION array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C FIDT - CHARACTER*5 -C On entry FIDT defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRT - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRT describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C -C T - DOUBLE PRECISION array of DIMENSION (*) -C On entry T specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IT1 - INTEGER array of dimension (*) -C On entry IT1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IT2 - INTEGER array of dimension (*) -C On entry IT2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOT - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - DOUBLE PRECISION array of dimension (LDB,*) -C On entry: matrix of right-hand sides -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION array of dimension (LDC,*) -C On exit: solutions of triangular systems -C -C LDC - INTEGER -C On entry: leading dimension of C. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSWSM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Note -C ==== -C All checks on argument are performed in the calling routine. -C -C - SUBROUTINE SSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_error_mod - use psb_string_mod - implicit none -C .. Scalar Arguments .. - INTEGER M, N, LDB, LDC, LWORK, IERROR - CHARACTER UNITD, TRANS - real(psb_dpk_) ALPHA, BETA -C .. Array Arguments .. - INTEGER IT1(*), IT2(*), INFOT(*) - CHARACTER DESCRT*11, FIDT*5 - real(psb_dpk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) -C .. Local Scalars .. - INTEGER ONE -C .. Parameters .. - PARAMETER (ONE=1) -C .. External Subroutines .. - EXTERNAL DCSRSM, DCOPY - integer debug_level, debug_unit, err_act, int_val(5) - CHARACTER*20 NAME - -C .. Executable Statements .. - - NAME = 'DSWSM' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - work(1) = szero - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - -C -C Check for identity matrix -C - IF(psb_toupper(DESCRT(1:1)).EQ.'D' .AND. - + psb_toupper(DESCRT(3:3)).EQ.'U') THEN - CALL SCOPY(M,B,ONE,C,ONE) - GOTO 9998 - ENDIF - - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': entry ',m,n,ierror,' ',unitd -C -C Switching on FIDT: proper sparse BLAS routine is selected -C according to data structure -C - IF (psb_toupper(FIDT(1:3)).EQ.'CSR') THEN -C -C T, IT1, IT2 ---> AR, JA, IA -C VAL, INDX, PNTR -C INFOT(*) not used -C - CALL SCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, - & IT2,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - ELSE IF (psb_toupper(FIDT(1:3)).EQ.'JAD') THEN - - CALL SJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2, - + 0,B,LDB,BETA,C,LDC,WORK) - - ELSE IF (psb_toupper(FIDT(1:3)).EQ.'COO') THEN - - CALL SCOOSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1,IT2,INFOT, - + B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/zcsmm.f b/base/serial/f77/zcsmm.f deleted file mode 100644 index 8dd52ca99..000000000 --- a/base/serial/f77/zcsmm.f +++ /dev/null @@ -1,380 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE ZCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, -C INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C Purpose -C ======= -C -C Computing matrix-matrix product -C C <-- ALPHA PL A PR B + BETA C or -C C <-- ALPHA PL At PR B + BETA C or -C C <-- ALPHA PL Atc PR B + BETA C -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' -> use A' (transpose of matrix A) -C TRANS = 'C' -> use conjugate transpose of A -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C PL - INTEGER array of dimension (M) -C On entry PL specifies the row permutation of matrix A -C (PL(1) == 0 if no permutation). -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - COMPLEX*16 array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C PR - INTEGER array of dimension (K) -C On entry PR specifies the column permutation of matrix A -C (PR(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - COMPLEX*16 matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying ZCSMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = (LWORK for DxxxMM) + Pr*K*N + Pl*M*N -C where Pr íPlù = 1 if right íleftù permutation has to -C be performed, 0 otherwise. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Local Variables -C =============== -C -C LWORKM - INTEGER -C Minimum work area dimension for ZCSMM -C -C LWORKB - INTEGER -C Work area dimension for matrix B in subroutine DLPUPD -C -C LWORKC - INTEGER -C Work area dimension for matrix C in subroutine DLPUPD -C -C LWORKS - INTEGER -C Work area dimension for subroutine DSWMM -C -C P - INTEGER -C Pointer to work area -C -C LP - LOGICAL -C LP is true if left permutation is required -C -C RP - LOGICAL -C RP is true if right permutation is required -C -C Notes -C ===== -C Some tests have shown that it is more efficient to divide the -C sparse matrix-dense matrix multiplication step and the dense -C matrix permutation step, and it is more efficient to put -C together the left permutation and update (C <- xxx + BETA C) -C steps. So, the sequence of operations is: -C Right permutation ZLPUPD -C Matrix-Matrix product ZSWMM -C Left permutation and update ZLPUPD -C In order to avoid useless memory transfer, the above scheme is -C simplified according to whether right and left permutation have to -C be performed. If left permutation is not required, the update step -C is performed in the sparse matrix-dense matrix multiplication kernel. -C -C It is not possible to call this subroutine with LWORK=0 to get # -C the minimal value for LWORK. This functionality needs a better # -C connection with DxxxMM # -C -C - SUBROUTINE ZCSMM(TRANS,M,N,K,ALPHA,PL,FIDA,DESCRA,A,IA1,IA2, - & INFOA,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N,K,LDB,LDC,LWORK, IERROR - CHARACTER TRANS - complex(psb_dpk_) ALPHA,BETA -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*),PL(*),PR(*) - CHARACTER DESCRA*11, FIDA*5 - complex(psb_dpk_) A(*),B(LDB,*),C(LDC,*),WORK(*) -C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKC, LWORKS, P, ERR_ACT - LOGICAL LP, RP -C .. Local Array.. - INTEGER INT_VAL(5) - CHARACTER*30 NAME, STRINGS(2) -C .. External Subroutines .. - EXTERNAL ZSWMM, ZLPUPD, XERBLA -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT -C .. Executable Statements .. -C -C Check for argument errors -C - NAME = 'ZCSMM\0' - IERROR=0 - - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (K.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 4 - INT_VAL(2) = K - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (LDB.LT.K) THEN - IERROR = 50 - INT_VAL(1) = 15 - INT_VAL(2) = 4 - INT_VAL(3) = LDB - INT_VAL(4) = K - ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 18 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Inizializations -C - LP = PL(1).NE.0 - RP = PR(1).NE.0 - LWORKB = K*N - LWORKC = M*N - LWORKM = 0 - IF (RP) LWORKM = LWORKB - IF (LP) LWORKM = LWORKM + LWORKC - IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 20 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - LWORKS = LWORK - LWORKM - -C -C Check for M, N, K -C - IF(M.LE.0 .OR. N.LE.0 .OR. K.LE.0) THEN - GOTO 9999 - ENDIF -C -C Switching on PR and PL -C - IF (LP .AND. RP) THEN -C -C Both right and left permutation required -C - P=LWORKB+1 - CALL ZLPUPD(K,N,PR,B,LDB,ZZERO,WORK,K) - CALL ZSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,ZZERO,WORK(P),M,WORK(P+LWORKC),LWORKS,IERROR) - LWORKS = IDINT(DBLE(WORK(P+LWORKC))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDA//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL ZLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) - ELSE IF(.NOT.LP .AND. RP) THEN -C -C Only right permutation required -C - P=LWORKB+1 - CALL ZLPUPD(K,N,PR,B,LDB,ZZERO,WORK,K) - CALL ZSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & WORK,K,BETA,C,LDC,WORK(P),LWORKS,IERROR) - LWORKS = IDINT(DBLE(WORK(P))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDA//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE IF(.NOT.RP .AND. LP) THEN -C -C Only left permutation required -C - P=LWORKC+1 - CALL ZSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,ZZERO,WORK,M,WORK(P),LWORKS,IERROR) - LWORKS = IDINT(DBLE(WORK(P))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDA//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - - CALL ZLPUPD(M,N,PL,WORK,M,BETA,C,LDC) - ELSE IF(.NOT.RP .AND. .NOT.LP) THEN -C -C No permutations required -C - CALL ZSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2,INFOA, - & B,LDB,BETA,C,LDC,WORK,LWORKS,IERROR) - LWORKS = IDINT(DBLE(WORK(1))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDA//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - - GOTO 9999 - ENDIF - ENDIF - ENDIF -C -C Return minimum workarea dimension -C - LWORKM = LWORKM + LWORKS - WORK(1) = DBLE(LWORKM) - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - - RETURN - END - - diff --git a/base/serial/f77/zcsnmi.f b/base/serial/f77/zcsnmi.f deleted file mode 100644 index 34262d121..000000000 --- a/base/serial/f77/zcsnmi.f +++ /dev/null @@ -1,185 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C DOUBLE PRECISION FUNCTION ZCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & -C & INFOA,IERROR) -C Purpose -C ======= -C -C Computing matrix infinity norm -C nrmi <-- ||A||infty or -C nrmi <-- ||At||infty -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix A. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Notes -C ===== -C - FUNCTION ZCSNMI(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,IERROR) - use psb_const_mod - use psb_string_mod - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) zcsnmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - complex(psb_dpk_) A(*) -C .. Local Array.. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME, STRINGS(2) -C .. External Subroutines .. - real(psb_dpk_) ZCRNRMI, ZCOONRMI - EXTERNAL ZCRNRMI, ZCOONRMI -C .. Executable Statements .. -C -C Check for argument errors -C - IERROR = 0 - NAME = 'ZCSNMI\0' - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Check for M, N, K -C - IF(M.LE.0 .OR. N.LE.0) THEN - ZCSNMI = 0.D0 - GOTO 9999 - ENDIF - -C ... Compute infinity norm for matrix A ... - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN - ZCSNMI = ZCRNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) -c$$$ ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN -c$$$ ZCSNMI = ZJDNRMI(TRANS,M,N,DESCRA,A,IA1,IA2, -c$$$ + INFOA,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN - ZCSNMI = ZCOONRMI(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - RETURN - END diff --git a/base/serial/f77/zcsrws.f b/base/serial/f77/zcsrws.f deleted file mode 100644 index d220e97f7..000000000 --- a/base/serial/f77/zcsrws.f +++ /dev/null @@ -1,191 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE DCSRS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, & -C & INFOA,ROWSUM,IERROR) -C Purpose -C ======= -C -C Computing sum of absolute values for rows of distributed matrix -C ROWSUM(IX) = ASUM(A(IX, 1..N)) -C IX = 1..M -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' or 'C' -> use A' (transpose of matrix A) -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - DOUBLE PRECISION array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C ROWSUM - DOUBLE PRECISION array of dimension (*) -C On exit this vector contains the sum of absolute values -C of elements of a row (AMAX of row array). -C It is required that it has dimension: -C ROWSUM(M) if the subroutine in called with the 'N' option -C ROWSUM(N) in other cases ('T' or 'C' options). -C - SUBROUTINE ZCSRWS(TRANS,M,N,FIDA,DESCRA,A,IA1,IA2, - & INFOA,ROWSUM,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - complex(psb_dpk_) A(*), ROWSUM(*) -C .. Local Array.. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME,STRINGS(2) -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT -C .. Executable Statements .. -C -C Check for argument errors -C - - IERROR = 0 - NAME = 'ZCSRWS\0' - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - - IF(M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 - ENDIF - - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN - CALL ZCSRRWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN - CALL ZCOORWS(TRANS,M,N,DESCRA,A,IA1,IA2, - + INFOA,ROWSUM,IERROR) -c$$$ ELSE IF (psb_toupper(FIDA(1:3)).EQ.'JAD') THEN -c$$$ CALL DJDRWS(TRANS,M,N,DESCRA,A,IA1,IA2, -c$$$ + INFOA,ROWSUM,IERROR) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - strings(1) = fida//'\0' - ENDIF - - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END - - diff --git a/base/serial/f77/zcssm.f b/base/serial/f77/zcssm.f deleted file mode 100644 index 97e5094f6..000000000 --- a/base/serial/f77/zcssm.f +++ /dev/null @@ -1,380 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE ZCSSM(TRANS,M,N,ALPHA,UNITD,D,PL,FIDT,DESCRT,T,IT1,IT2, -C INFOT,PR,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Solving triangular systems of equations with multiple right-hand sides -C C <-- ALPHA PL D T-1 PR B + BETA C or -C C <-- ALPHA PL D T-t PR B + BETA C or -C C <-- ALPHA PL T-1 D PR B + BETA C or -C C <-- ALPHA PL T-t D PR B + BETA C -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine operates with -C matrix T or with the transpose of T as follows: -C TRANS = 'N' -> use matrix T -C TRANS = 'T' -> use T' (transpose of matrix T) -C TRANS = 'C' -> use conjugate transpose of T -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows and columns of matrix Ty -C and number of rows of matrices B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrices B and C -C (number of right-hand sides). -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - COMPLEX*16 array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C PL - INTEGER array of dimension (M) -C On entry PL specifies the row permutation of matrix T -C (PL(1) == 0 if no permutation). -C Unchanged on exit. -C -C FIDT - CHARACTER*5 -C On entry FIDT defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRT - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRT describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C -C T - CONPLEX*16 array of DIMENSION (*) -C On entry T specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IT1 - INTEGER array of dimension (*) -C On entry IT1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IT2 - INTEGER array of dimension (*) -C On entry IT2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOT - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C PR - INTEGER array of dimension (M) -C On entry PR specifies the column permutation of matrix T -C (PR(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - COMPLEX*16 array of dimension (LDB,*) -C On entry: matrix of right-hand sides -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 array of dimension (LDC,*) -C On exit: solutions of triangular systems -C -C LDC - INTEGER -C On entry: leading dimension of C. -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DCSSM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = (LWORK for DxxxSM) + Pr*M*N + Pl*M*N -C where Pr íPlù = 1 if right íleftù permutation has to -C be performed, 0 otherwise. -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Local Variables -C =============== -C -C LWORKM - INTEGER -C Minimum work area dimension for ZCSSM -C -C LWORKB - INTEGER -C Work area dimension for matrices B, C in subroutines ZLPUPD -C -C LWORKS - INTEGER -C Work area dimension for subroutine ZSWSM -C -C P - INTEGER -C Pointer to work area -C -C LP - LOGICAL -C LP is true if left permutation is required -C -C RP - LOGICAL -C RP is true if right permutation is required -C -C Notes -C ===== -C Some tests have shown that it is more efficient to divide the -C sparse matrix-dense matrix multiplication step and the dense -C matrix permutation and update (C <- xxx + BETA C) step. -C So, the sequence of operations is: -C Right permutation ZLPUPD -C Matrix-Matrix product ZSWSM -C Left permutation and update ZLPUPD -C In order to avoid useless memory transfer, the above scheme is -C simplified according to whether right and left permutation -C have to be performed. -C -C - SUBROUTINE ZCSSM(TRANS,M,N,ALPHA,UNITD,D,PL, - + FIDT,DESCRT,T,IT1,IT2,INFOT,PR,B,LDB,BETA,C,LDC, - + WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - IMPLICIT NONE - complex(psb_dpk_) ALPHA, BETA - INTEGER N, LDB, LDC, M, LWORK, IERROR - CHARACTER UNITD, TRANS -C .. Array Arguments .. - complex(psb_dpk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - INTEGER IT1(*), IT2(*), INFOT(*), PL(*), PR(*) - CHARACTER DESCRT*11, FIDT*5 -C .. Local Scalars .. - INTEGER LWORKM, LWORKB, LWORKS, P - complex(psb_dpk_) ZERO - LOGICAL LP, RP -C .. Local Array.. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME, STRINGS(2) -C .. Parameters .. - PARAMETER (ZERO = (0.D0, 0.D0)) -C .. External Subroutines .. - EXTERNAL ZSWSM, ZLPUPD -C .. Intrinsic Functions .. - INTRINSIC DBLE, IDINT -C .. Executable Statements .. -C -C Check for argument errors -C - NAME = 'ZCSSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - IF (M.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 2 - INT_VAL(2) = M - ELSE IF (N.LT.0) THEN - IERROR = 10 - INT_VAL(1) = 3 - INT_VAL(2) = N - ELSE IF (psb_toupper(TRANS).NE.'T' .AND. - + psb_toupper(TRANS).NE.'N' .AND. - + psb_toupper(TRANS).NE.'C') THEN - IERROR = 40 - INT_VAL(1) = 1 - STRINGS(1) = TRANS//'\0' - ELSE IF (psb_toupper(UNITD).NE.'U' .AND. - + psb_toupper(UNITD).NE.'L' .AND. - + psb_toupper(UNITD).NE.'R' .AND. - + psb_toupper(UNITD).NE.'B') THEN - IERROR = 40 - INT_VAL(1) = 5 - STRINGS(1) = UNITD//'\0' - ELSE IF (LDB.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 16 - INT_VAL(2) = 2 - INT_VAL(3) = LDB - INT_VAL(4) = M - ELSE IF (LDC.LT.M) THEN - IERROR = 50 - INT_VAL(1) = 19 - INT_VAL(2) = 2 - INT_VAL(3) = LDC - INT_VAL(4) = M - ENDIF - -C -C Error handling -C - IF(IERROR.NE.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - -C -C Inizializations -C - LP = PL(1).NE.0 - RP = PR(1).NE.0 - LWORKB = M*N - LWORKM = 0 - IF (RP) LWORKM = LWORKB - IF (LP) LWORKM = LWORKM + LWORKB - P = LWORKB+1 - IF (LWORK.LT.LWORKM) THEN - IERROR = 60 - INT_VAL(1) = 21 - INT_VAL(2) = LWORKM - INT_VAL(3) = LWORK - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - LWORKS = LWORK - LWORKM - -C Check for M, N -C - IF (M.LE.0 .OR. N.LE.0) THEN - GOTO 9999 - ENDIF -C -C Switching on xP -C - IF (LP .AND. RP) THEN -C -C Both right and left permutations required -C - CALL ZLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL ZSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,ZERO,WORK(P),M,WORK(P+LWORKB),lworks,IERROR) - LWORKS = IDINT(DBLE(WORK(P+LWORKB))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDT//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL ZLPUPD(M,N,PL,WORK(P),M,BETA,C,LDC) - ELSE IF(.NOT.LP .AND. RP) THEN -C -C Only right permutation required -C - CALL ZLPUPD(M,N,PR,B,LDB,BETA,WORK,M) - CALL ZSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,WORK,M,ZERO,C,LDC,WORK(P),lworks,IERROR) - LWORKS = IDINT(DBLE(WORK(P))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDT//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ELSE IF(.NOT.RP .AND. LP) THEN -C -C Only left permutation required -C - CALL ZSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,WORK,M,WORK(P),lworks,IERROR) - LWORKS = IDINT(DBLE(WORK(P))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDT//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - CALL ZLPUPD(M,N,PL,WORK,M,BETA,C,LDC) - ELSE IF(.NOT.RP .AND. .NOT.LP) THEN -C -C Only triangular systems solver required -C - CALL ZSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,lworks,IERROR) - LWORKS = IDINT(DBLE(WORK(1))) - IF(IERROR .NE. 0) THEN - IF (IERROR.EQ.3010) THEN - STRINGS(1) = FIDT//'\0' - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - ENDIF - ENDIF -C -C Return minimum workarea dimension -C - LWORKM = LWORKM + LWORKS - WORK(1) = DBLE(LWORKM) - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - RETURN - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - ENDIF - RETURN - - END - diff --git a/base/serial/f77/zgelp.f b/base/serial/f77/zgelp.f deleted file mode 100644 index 1b7b807e7..000000000 --- a/base/serial/f77/zgelp.f +++ /dev/null @@ -1,204 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C SUBROUTINE DGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C Computing -C B <-- op(P) B -C where op(P) is permutation matrix P or its transpose. -C Notice: when B is a diagonal matrix and it is stored as -C a vector whose entry i is B(i,i), this routine computes -C B <-- P B P(-1) -C where P(-1) is the inverse of P. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whetherif the routine operates with -C matrix P or with the transpose of P as follows: -C TRANS = 'N' -> use matrix P -C TRANS = 'T' OR 'C' -> use the transpose of matrix P -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows of matrix B. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B. -C Unchanged on exit. -C -C P - INTEGER array of dimension (M) -C On entry P specifies the row permutation of matrix B -C (P(1) == 0 if no permutation). -C Unchanged on exit. -C -C B - DOUBLE PRECISION array of dimension (LDB,*) -C On entry: dense matrix. -C On exit: permuted matrix. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C WORK - DOUBLE PRECISION array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DGELP memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C LWORK should be set as follows: -C LWORK = M -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C - SUBROUTINE ZGELP(TRANS,M,N,P,B,LDB,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER LDB, M, N, LWORK, IERROR - CHARACTER TRANS -C .. Array Arguments .. - complex(psb_dpk_) B(LDB,*), WORK(*) - INTEGER P(*) -C .. Local Scalars .. - INTEGER I, J, ERR_ACT - logical istran,isnotran -C .. Local Arrays.. - INTEGER INT_VAL -C .. Intrinsic Functions .. - INTRINSIC DBLE - logical psb_lsame - external psb_lsame - - character*20 name -c -C .. Executable Statements .. -C -C -C Check on M, N, LDB, LWORK, TRANS -C - NAME = 'ZGELP\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - isnotran = psb_lsame(psb_toupper(trans),'N') - istran = psb_lsame(psb_toupper(trans),'T') .or. - + psb_lsame(psb_toupper(trans),'C') - IF (M.LT.0) THEN - IERROR = 7 - ELSE IF(N.LT.0) THEN - IERROR = 3 - ELSE IF(M.GT.LDB) THEN - IERROR = -6 - ELSE IF (LWORK.LT.M) THEN - IF (LWORK.EQ.0) THEN -C -C Return minimum LWORK -C - IERROR = 8 - WORK(1) = DBLE(M) - GOTO 9998 - ELSE IF(LWORK.NE.0) THEN - IERROR = -8 - ENDIF - ELSE IF (.not.istran.and..not.isnotran) THEN - IERROR = -1 - ENDIF -C -C Error handling -C - IF(IERROR.LT.0) THEN - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Check for M, N, P -C - IF(M.LE.0 .OR. N.LE.0 .OR. P(1).EQ.0) THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF -C -C Switch on TRANS -C - IF (isnotran) THEN -C -C Permuting with P -C - DO 60 J = 1, N - DO 20 I = 1, M - WORK(I) = B(P(I),J) - 20 CONTINUE - DO 40 I = 1, M - B(I,J) = WORK(I) - 40 CONTINUE - 60 CONTINUE - ELSE IF (istran) THEN -C -C Permuting with the transpose of P. -C - DO 160 J = 1, N - DO 120 I = 1, M - WORK(P(I)) = B(I,J) - 120 CONTINUE - DO 140 I = 1, M - B(I,J) = WORK(I) - 140 CONTINUE - 160 CONTINUE - END IF - - 9998 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/f77/zlpupd.f b/base/serial/f77/zlpupd.f deleted file mode 100644 index 80e682a02..000000000 --- a/base/serial/f77/zlpupd.f +++ /dev/null @@ -1,116 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C Subroutine ZLPUPD(M,N,PERM,B,LDB,BETA,C,LDC,IERROR) -C Purpose -C ======= -C -C Computing C <-- PERM B + BETA C -C where PERM is a permutation matrix. -C -C Parameters -C ========== -C -C M - INTEGER -C On entry M specifies the number of rows of matrices -C B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry N specifies the number of columns of matrices -C B and C. -C Unchanged on exit. -C -C PERM - INTEGER array of dimension (N) -C On entry PERM specifies the values of a permutation matrix. -C Unchanged on exit. -C -C B - DOUBLE PRECISION matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry LDB holds the value of the leading dimension of B -C Unchanged on exit. -C -C BETA - DOUBLE PRECISION -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - DOUBLE PRECISION matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated as shown above. -C -C LDC - INTEGER -C On entry LDC holds the value of the leading dimension of C -C Unchanged on exit. -C -C Note -C ==== -C All checks on argument are performed in the calling routines. -C -C - SUBROUTINE ZLPUPD(M,N,PERM,B,LDB,BETA,C,LDC) - use psb_const_mod -C .. Scalar Arguments .. - INTEGER M, N, LDB, LDC - complex(psb_dpk_) BETA -C .. Array Arguments .. - INTEGER PERM(*) - complex(psb_dpk_) B(LDB,*), C(LDC,*) -C .. Local Scalars .. - INTEGER I,J -C -C .. Executable Statements .. -C -C Switching on BETA -C - IF (BETA.NE.(0.D0,0.d0)) THEN -C -C Performing left permutation and update -C - DO 40 J = 1, N - DO 30 I = 1, M - C(I,J) = B(PERM(I),J) + BETA*C(I,J) - 30 CONTINUE - 40 CONTINUE - ELSE IF(BETA.EQ.(0.D0,0.d0)) THEN -C -C Performing right or left permutation -C - DO 160 J = 1, N - DO 150 I = 1, M - C(I,J) = B(PERM(I),J) - 150 CONTINUE - 160 CONTINUE - ENDIF - RETURN - END diff --git a/base/serial/f77/zswmm.f b/base/serial/f77/zswmm.f deleted file mode 100644 index d08395a5c..000000000 --- a/base/serial/f77/zswmm.f +++ /dev/null @@ -1,220 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE ZSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, -C INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C Purpose -C ======= -C -C Computing C <-- ALPHA A B + BETA C or -C C <-- ALPHA At B + BETA C or -C C <-- ALPHA Atc B + BETA C -C Called by ZCSMM -C Actual computing performed by sparse Toolkit kernels. -C This routine selects the proper kernel for each -C data structure. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies if the routine operates with matrix A -C or with the transpose of A as follows: -C TRANS = 'N' -> use matrix A -C TRANS = 'T' -> use A' (transpose of matrix A) -C TRANS = 'C' -> use conjugate transpose of A -C Unchanged on exit. -C -C N.B.: M, N for C matrix -C M, K for A matrix -C K, N for B matrix -C -C M - INTEGER -C On entry: number of rows of matrix A (A') and -C number of rows of matrix C -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrix B -C and number of columns of matrix C. -C Unchanged on exit. -C -C K - INTEGER -C On entry: number of columns of matrix A (A') and -C number of rows of matrix B -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C FIDA - CHARACTER*5 -C On entry FIDA defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRA - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRA describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C A - COMPLEX*16 array of DIMENSION (*) -C On entry A specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IA1 - INTEGER array of dimension (*) -C On entry IA1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IA2 - INTEGER array of dimension (*) -C On entry IA2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOA - INTEGER array of length 10. -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - COMPLEX*16 matrix of dimension (LDB,*) -C On entry: dense matrix. -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 matrix of dimension (LDC,*) -C On entry: dense matrix. -C On exit is updated with the matrix-matrix product. -C -C LDC - INTEGER -C On entry: leading dimension of C -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying ZSWMM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Note -C ==== -C All checks on argument are performed in the calling routine. -C -C - SUBROUTINE ZSWMM(TRANS,M,N,K,ALPHA,FIDA,DESCRA,A,IA1,IA2, - & INFOA,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod - use psb_const_mod -C .. Scalar Arguments .. - INTEGER M,N,K,LDB,LDC,LWORK,IERROR - CHARACTER TRANS - complex(psb_dpk_) ALPHA,BETA -C .. Array Arguments .. - INTEGER IA1(*),IA2(*),INFOA(*) - CHARACTER DESCRA*11, FIDA*5 - complex(psb_dpk_) A(*),B(LDB,*),C(LDC,*),WORK(*) -C .. Local Array .. - INTEGER INT_VAL(5), ERR_ACT - CHARACTER*30 NAME, STRINGS(2) -C .. External Subroutines .. - EXTERNAL ZCSRMM -C + ZJADMM -C .. Executable Statements .. -C -C Switching on FIDA: proper sparse BLAS routine is selected -C according to data structure -C - NAME = 'ZSWMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - WORK(1) = zzero - IF (psb_toupper(FIDA(1:3)).EQ.'CSR') THEN -C -C A, IA1, IA2 ---> AR, JA, IA -C VAL, INDX, PNTR -C INFOA(*) not used - CALL ZCSRMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - & IA2,B,LDB,BETA,C,LDC,WORK,LWORK) -C -C JAD format not jet implemented -C - ELSE IF (psb_toupper(FIDA(1:3)).EQ.'COO') THEN -C -C INFOA(*) not used -C - CALL ZCOOMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, - + IA2,INFOA,B,LDB,BETA,C,LDC,WORK) - ELSE IF ((psb_toupper(FIDA(1:3)).EQ.'JAD').AND.(.FALSE.)) THEN -C -C INFOA(*) not used -C -C CALL ZJADMM(TRANS,M,N,K,ALPHA,DESCRA,A,IA1, -C & IA2,B,LDB,BETA,C,LDC,WORK) - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - STRINGS(1) = FIDA(1:4) - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - - END IF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - END - diff --git a/base/serial/f77/zswsm.f b/base/serial/f77/zswsm.f deleted file mode 100644 index 931e931b5..000000000 --- a/base/serial/f77/zswsm.f +++ /dev/null @@ -1,230 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C SUBROUTINE ZSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, -C INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) -C -C Purpose -C ======= -C -C Solving triangular systems of equations with multiple right-hand sides -C C <-- ALPHA D T-1 B + BETA C or -C C <-- ALPHA D T-t B + BETA C or -C C <-- ALPHA T-1 D B + BETA C or -C C <-- ALPHA T-t D B + BETA C -C Actual computing performed by sparse Toolkit kernels. -C This routine selects the proper kernel for each -C data structure. -C -C Parameters -C ========== -C -C TRANS - CHARACTER*1 -C On entry TRANS specifies whether the routine operates with -C matrix T or with the transpose of T as follows: -C TRANS = 'N' -> use matrix T -C TRANS = 'T' -> use T' (transpose of matrix T) -C TRANS = 'C' -> use conjugate transpose of T -C Unchanged on exit. -C -C M - INTEGER -C On entry: number of rows and columns of matrix T -C and number of rows of matrices B and C. -C Unchanged on exit. -C -C N - INTEGER -C On entry: number of columns of matrices B and C -C (number of right-hand sides). -C Unchanged on exit. -C -C ALPHA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C UNITD - CHARACTER*1 -C On entry UNITD specifies whether the diagonal matrix is unit -C or whether row or column scaling has to be performed, as follows: -C UNITD = 'U' -> unit matrix (no scaling) -C UNITD = 'L' -> scale on the left (row scaling) -C UNITD = 'R' -> scale on the right (column scaling) -C UNITD = 'B' -> scale on the right and on the left -C with D^1/2 -C Unchanged on exit. -C -C D - COMPLEX*16 array of dimension (M) -C On entry D specifies the main diagonal of the matrix used -C for scaling. -C Unchanged on exit. -C -C FIDT - CHARACTER*5 -C On entry FIDT defines the format of the input sparse matrix. -C Unchanged on exit. -C -C DESCRT - CHARACTER*1 array of DIMENSION (9) -C On entry DESCRT describes the characteristics of the input -C sparse matrix. -C Unchanged on exit. -C -C -C T - COMPLEX*16 array of DIMENSION (*) -C On entry T specifies the values of the input sparse -C matrix. -C Unchanged on exit. -C -C IT1 - INTEGER array of dimension (*) -C On entry IT1 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C IT2 - INTEGER array of dimension (*) -C On entry IT2 holds integer information on input sparse -C matrix. Actual information will depend on data format used. -C Unchanged on exit. -C -C INFOT - INTEGER array of dimension (10) -C On entry can hold auxiliary information on input matrices -C formats or environment of subsequent calls. -C Might be changed on exit. -C -C B - COMPLEX*16 array of dimension (LDB,*) -C On entry: matrix of right-hand sides -C Unchanged on exit. -C -C LDB - INTEGER -C On entry: leading dimension of B. -C Unchanged on exit. -C -C BETA - COMPLEX*16 -C On entry: multiplicative constant. -C Unchanged on exit. -C -C C - COMPLEX*16 array of dimension (LDC,*) -C On exit: solutions of triangular systems -C -C LDC - INTEGER -C On entry: leading dimension of C. -C Unchanged on exit. -C -C WORK - COMPLEX*16 array of dimension (LWORK) -C On entry: work area. -C On exit INT(WORK(1)) contains the minimum value -C for LWORK satisfying DSWSM memory requirements. -C -C LWORK - INTEGER -C On entry LWORK specifies the dimension of WORK -C Unchanged on exit. -C -C IERROR - INTEGER -C On exit IERROR contains the value of error flag as follows: -C IERROR = 0 no error -C IERROR > 0 warning -C IERROR < 0 fatal error -C -C Note -C ==== -C All checks on argument are performed in the calling routine. -C -C - SUBROUTINE ZSWSM(TRANS,M,N,ALPHA,UNITD,D,FIDT,DESCRT,T,IT1,IT2, - & INFOT,B,LDB,BETA,C,LDC,WORK,LWORK,IERROR) - use psb_const_mod - use psb_string_mod -C .. Scalar Arguments .. - INTEGER M, N, LDB, LDC, LWORK, IERROR - CHARACTER UNITD, TRANS - complex(psb_dpk_) ALPHA, BETA -C .. Array Arguments .. - INTEGER IT1(*), IT2(*), INFOT(*) - CHARACTER DESCRT*11, FIDT*5 - complex(psb_dpk_) T(*), B(LDB,*), C(LDC,*), D(*), WORK(*) - integer ERR_ACT -C .. Local Scalars .. - INTEGER ONE -C .. Parameters .. - PARAMETER (ONE=1) -C .. External Subroutines .. - EXTERNAL ZCSRSM, ZCOPY - CHARACTER*20 NAME - -C .. Executable Statements .. - NAME = 'ZSWSM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - WORK(1) = zzero -C -C Check for identity matrix -C - IF(psb_toupper(DESCRT(1:1)).EQ.'D' .AND. - + psb_toupper(DESCRT(3:3)).EQ.'U') THEN - CALL ZCOPY(M,B,ONE,C,ONE) - GOTO 9999 - ENDIF -C -C Switching on FIDT: proper sparse BLAS routine is selected -C according to data structure -C - IF (psb_toupper(FIDT(1:3)).EQ.'CSR') THEN -C -C T, IT1, IT2 ---> AR, JA, IA -C VAL, INDX, PNTR -C INFOT(*) not used -C - CALL ZCSRSM(TRANS,M,N,UNITD,D,ALPHA,DESCRT,T,IT1, - & IT2,B,LDB,BETA,C,LDC,WORK,LWORK) - ELSE IF ((psb_toupper(FIDT(1:3)).EQ.'JAD') - + .AND.(.FALSE.)) THEN -C -C .. JAD format not yet supported -C -C CALL ZJADSM(TRANS,M,N,D,UNITD,0,ALPHA,DESCRT,T,IT1,IT2,0, -C & B,LDB,BETA,C,LDC,WORK) -C - ELSE -C -C This data structure not yet considered -C - IERROR = 3010 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - ENDIF - - RETURN - END - - diff --git a/base/serial/jad/Makefile b/base/serial/jad/Makefile deleted file mode 100644 index 945760651..000000000 --- a/base/serial/jad/Makefile +++ /dev/null @@ -1,41 +0,0 @@ -include ../../../Make.inc -# -# The object files -# - -FOBJS = -# sjadmm.o sjadmv.o sjadsm.o sjadsv.o sjdnrmi.o sjadnr.o\ -# sjadmv2.o sjadmv3.o sjadmv4.o sjadrws.o sjdrws.o - -#djadmm.o djadmv.o djadsm.o djadsv.o djdnrmi.o djadnr.o\ -# djadmv2.o djadmv3.o djadmv4.o djadrws.o djdrws.o \ - - -OBJS=$(FOBJS) - -# -# Where the library should go, and how it is called. -# Note that we are regenerating most of libsparker.a on the fly. -SPARKERDIR=.. -LIBDIR=../.. -MODDIR=../../modules -FINCLUDES=$(FMFLAG)$(LIBDIR) $(FMFLAG)$(MODDIR) $(FMFLAG)$(SPARKERDIR) $(FMFLAG). -LIBFILE=$(LIBDIR)/$(LIBNAME) - -# -# No change should be needed below -# - -default: lib - -lib: $(OBJS) - $(AR) $(LIBDIR)/$(LIBNAME) $(OBJS) - $(RANLIB) $(LIBDIR)/$(LIBNAME) - -clean: cleanobjs - -veryclean: cleanobjs - -cleanobjs: - /bin/rm -f $(OBJS) - diff --git a/base/serial/jad/djadmm.f b/base/serial/jad/djadmm.f deleted file mode 100644 index 542824a37..000000000 --- a/base/serial/jad/djadmm.f +++ /dev/null @@ -1,144 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DJADMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * JA,IA,B,LDB,BETA,C,LDC,WORK,IERROR) - use psb_const_mod - IMPLICIT NONE -C -C -C .. Scalar Arguments .. - real(psb_dpk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N,IERROR - CHARACTER TRANSA -C .. Array Arguments .. - real(psb_dpk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - integer PIA, PJA, PNG - INTEGER I, J, KB,NB, ERR_ACT - CHARACTER DIAG, TRANS -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) -C .. Executable Statements .. -C - - NAME = 'DJADMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - TRANS = TRANSA - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' - IF (DESCRA(1:1).EQ.'D') THEN - IF (DESCRA(3:3).EQ.'U') THEN - DO 40 I = 1, K - DO 20 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) - 20 CONTINUE - 40 CONTINUE - ELSE - DO 80 I = 1, K - DO 60 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*AR(J)*B(J,I) - 60 CONTINUE - 80 CONTINUE - END IF - RETURN - END IF - IF (TRANS.EQ.'T'.or.TRANS.EQ.'C') THEN - IERROR = 3015 - RETURN - ENDIF -C - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' - PNG = IA(1) - PIA = IA(2) - PJA = IA(3) -* write(6,*)'M N K',m,n,k - - NB = 4 - KB = MOD(K,NB) - - SELECT CASE(KB) - CASE (1) - IF (K==1) THEN - CALL DJADMV(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,1),BETA,C(1,1),IERROR) - ELSE - CALL DJADMV2(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) - CALL DJADMV3(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,3),LDB,BETA,C(1,3),LDC,IERROR) - KB = KB + 4 - ENDIF - CASE(2) - CALL DJADMV2(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) - CASE(3) - CALL DJADMV3(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) - - END SELECT - - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - DO I=KB+1,K,NB - CALL DJADMV4(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,I),LDB,BETA,C(1,I),LDC,IERROR) - END DO - - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/jad/djadmv.f b/base/serial/jad/djadmv.f deleted file mode 100644 index d6358c467..000000000 --- a/base/serial/jad/djadmv.f +++ /dev/null @@ -1,352 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* PROCEDURAL LOGIC SECTION * -* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * -* DOUBLE PRECISION ZERO * -* PARAMETER (ZERO=0.0D0) * -* DOUBLE PRECISION ACC * -* INTEGER I, J, K, IPX, IPG * -* LOGICAL UNI * -*C .. Executable Statements .. * -*C * -*C * -* IF (DIAG.EQ.'U') THEN * -* DO 10 I = 1, M * -* Y(I) = BETA*Y(I) + ALPHA*X(I) * -* 10 CONTINUE * -* ELSE * -* DO 20 I = 1, M * -* Y(I) = BETA*Y(I) * -* 20 CONTINUE * -* END IF * -* * -* IF (ALPHA.EQ.ZERO) THEN * -* RETURN * -* END IF * -*C * -*C * -*C DO 200 IPG = 1, NG * -* DO 50 K = IA(2,IPG), IA(3,IPG)-1 * -* IPX = IA(1,IPG) * -* DO 40 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* IPX = IPX + 1 * -* 40 CONTINUE * -* 50 CONTINUE * -*C * -*C * -* IPX = IA(1,IPG) * -* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * -* DO 60 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* 60 CONTINUE * -* IPX = IPX + 1 * -* 70 CONTINUE * -* 200 CONTINUE * -*C * -* RETURN * -*C * -*C * -* END * -* * -* * -*********************************************************************** - SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X, - + BETA,Y,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) A(*),X(*),Y(*),ALPHA,BETA,ZERO - INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,IERROR - CHARACTER DIAG - PARAMETER (ZERO=0.0D0) - INTEGER I, K, IPX, IPG, I0, IN - INTEGER NPG - real(psb_dpk_) Y0, Y1, Y2, Y3, Y4, Y5, Y6, Y7, - + Y8, Y9, Y10, Y11, Y12, Y13, Y14, Y15 -c .. Executable Statements .. -c -c - IERROR=0 - IF (DIAG.EQ.'U') THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, NROW - Y(I) = ALPHA*X(I) - ENDDO - ELSE - DO 10 I = 1, NROW - Y(I) = BETA*Y(I) + ALPHA*X(I) - 10 CONTINUE - ENDIF - ELSE - IF (BETA.EQ.ZERO) THEN - DO I = 1, NROW - Y(I) = 0.D0 - ENDDO - ELSE - DO 20 I = 1, NROW - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ENDIF - - IF (ALPHA.EQ.ZERO) THEN - RETURN - END IF -c -c - DO 200 IPG = 1, NG - K = IA(2,IPG) - NPG = JA(K+1)-JA(K) - - IF (NPG.EQ.4) THEN - IPX = IA(1,IPG) - Y0 = ZERO - Y1 = ZERO - Y2 = ZERO - Y3 = ZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+3, 4 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - - ELSE IF (NPG.EQ.5) THEN - - IPX = IA(1,IPG) - Y0 = ZERO - Y1 = ZERO - Y2 = ZERO - Y3 = ZERO - Y4 = ZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+4, 5 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - - ELSE IF (NPG.EQ.6) THEN - - IPX = IA(1,IPG) - Y0 = ZERO - Y1 = ZERO - Y2 = ZERO - Y3 = ZERO - Y4 = ZERO - Y5 = ZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+5, 6 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - Y5 = Y5 + A(I+5)*X(KA(I+5)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 - - ELSE IF (NPG.EQ.7) THEN - - IPX = IA(1,IPG) - Y0 = ZERO - Y1 = ZERO - Y2 = ZERO - Y3 = ZERO - Y4 = ZERO - Y5 = ZERO - Y6 = ZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+6, 7 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - Y5 = Y5 + A(I+5)*X(KA(I+5)) - Y6 = Y6 + A(I+6)*X(KA(I+6)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 - Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 - - ELSE IF (NPG.EQ.8) THEN - - IPX = IA(1,IPG) - Y0 = ZERO - Y1 = ZERO - Y2 = ZERO - Y3 = ZERO - Y4 = ZERO - Y5 = ZERO - Y6 = ZERO - Y7 = ZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+7, 8 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - Y5 = Y5 + A(I+5)*X(KA(I+5)) - Y6 = Y6 + A(I+6)*X(KA(I+6)) - Y7 = Y7 + A(I+7)*X(KA(I+7)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 - Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 - Y(IPX+7) = Y(IPX+7) + ALPHA*Y7 - - ELSE IF (NPG.EQ.16) THEN - - IPX = IA(1,IPG) - Y0 = ZERO - Y1 = ZERO - Y2 = ZERO - Y3 = ZERO - Y4 = ZERO - Y5 = ZERO - Y6 = ZERO - Y7 = ZERO - Y8 = ZERO - Y9 = ZERO - Y10 = ZERO - Y11 = ZERO - Y12 = ZERO - Y13 = ZERO - Y14 = ZERO - Y15 = ZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+15, 16 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - Y5 = Y5 + A(I+5)*X(KA(I+5)) - Y6 = Y6 + A(I+6)*X(KA(I+6)) - Y7 = Y7 + A(I+7)*X(KA(I+7)) - Y8 = Y8 + A(I+8)*X(KA(I+8)) - Y9 = Y9 + A(I+9)*X(KA(I+9)) - Y10 = Y10 + A(I+10)*X(KA(I+10)) - Y11 = Y11 + A(I+11)*X(KA(I+11)) - Y12 = Y12 + A(I+12)*X(KA(I+12)) - Y13 = Y13 + A(I+13)*X(KA(I+13)) - Y14 = Y14 + A(I+14)*X(KA(I+14)) - Y15 = Y15 + A(I+15)*X(KA(I+15)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 - Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 - Y(IPX+7) = Y(IPX+7) + ALPHA*Y7 - Y(IPX+8) = Y(IPX+8) + ALPHA*Y8 - Y(IPX+9) = Y(IPX+9) + ALPHA*Y9 - Y(IPX+10) = Y(IPX+10) + ALPHA*Y10 - Y(IPX+11) = Y(IPX+11) + ALPHA*Y11 - Y(IPX+12) = Y(IPX+12) + ALPHA*Y12 - Y(IPX+13) = Y(IPX+13) + ALPHA*Y13 - Y(IPX+14) = Y(IPX+14) + ALPHA*Y14 - Y(IPX+15) = Y(IPX+15) + ALPHA*Y15 - - ELSE - - DO K = IA(2,IPG), IA(3,IPG)-1 - IPX = IA(1,IPG) - DO I = JA(K), JA(K+1) - 1 - Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) - IPX = IPX + 1 - ENDDO - ENDDO - END IF - -c CSR Product - - IPX = IA(1,IPG) - DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 - DO 60 I = JA(K), JA(K+1) - 1 - Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) - 60 CONTINUE - IPX = IPX + 1 - 70 CONTINUE - 200 CONTINUE -c - RETURN - END - diff --git a/base/serial/jad/djadmv2.f b/base/serial/jad/djadmv2.f deleted file mode 100644 index c3828d73b..000000000 --- a/base/serial/jad/djadmv2.f +++ /dev/null @@ -1,360 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* PROCEDURAL LOGIC SECTION * -* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * -* DOUBLE PRECISION ZERO * -* PARAMETER (ZERO=0.0D0) * -* DOUBLE PRECISION ACC * -* INTEGER I, J, K, IPX, IPG * -* LOGICAL UNI * -*C .. Executable Statements .. * -*C * -*C * -* IF (DIAG.EQ.'U') THEN * -* DO 10 I = 1, M * -* Y(I) = BETA*Y(I) + ALPHA*X(I) * -* 10 CONTINUE * -* ELSE * -* DO 20 I = 1, M * -* Y(I) = BETA*Y(I) * -* 20 CONTINUE * -* END IF * -* * -* IF (ALPHA.EQ.ZERO) THEN * -* RETURN * -* END IF * -*C * -*C * -*C DO 200 IPG = 1, NG * -* DO 50 K = IA(2,IPG), IA(3,IPG)-1 * -* IPX = IA(1,IPG) * -* DO 40 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* IPX = IPX + 1 * -* 40 CONTINUE * -* 50 CONTINUE * -*C * -*C * -* IPX = IA(1,IPG) * -* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * -* DO 60 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* 60 CONTINUE * -* IPX = IPX + 1 * -* 70 CONTINUE * -* 200 CONTINUE * -*C * -* RETURN * -*C * -*C * -* END * -* * -* * -*********************************************************************** - SUBROUTINE DJADMV2(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, - + X,LDX,BETA,Y,LDY, IERROR) - use psb_const_mod - IMPLICIT NONE - INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR - real(psb_dpk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA - CHARACTER DIAG - real(psb_dpk_) ZERO - PARAMETER (ZERO=0.0D0) - INTEGER I, J, K, IPX, IPG, I0, IN - INTEGER NPG - integer nb - parameter (nb=2) - real(psb_dpk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), - + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), - + Y12(NB), Y13(NB), Y14(NB), Y15(NB) -c .. Executable Statements .. -c -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb - IERROR=0 - IF (DIAG.EQ.'U') THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = ALPHA*X(I,1:NB) - ENDDO - ELSE - DO 10 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) - 10 CONTINUE - ENDIF - ELSE - IF (BETA.EQ.ZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = 0.D0 - ENDDO - ELSE - DO 20 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) - 20 CONTINUE - END IF - ENDIF - - IF (ALPHA.EQ.ZERO) THEN - RETURN - END IF -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta - - do 200 ipg = 1, ng - k = ia(2,ipg) - npg = ja(k+1)-ja(k) - -c$$$ write(0,*) 'djadmv2:',npg - - if (npg.eq.4) then - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+3, 4 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - - else if (npg.eq.5) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+4, 5 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - - else if (npg.eq.6) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+5, 6 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - - else if (npg.eq.7) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+6, 7 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - - else if (npg.eq.8) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - y7(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+7, 8 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - - else if (npg.eq.16) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - y7(1:nb) = zero - y8(1:nb) = zero - y9(1:nb) = zero - y10(1:nb) = zero - y11(1:nb) = zero - y12(1:nb) = zero - y13(1:nb) = zero - y14(1:nb) = zero - y15(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+15, 16 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) - y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) - y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) - y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) - y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) - y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) - y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) - y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) - y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) - y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) - y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) - y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) - y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) - y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) - y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) - - else - - do k = ia(2,ipg), ia(3,ipg)-1 - ipx = ia(1,ipg) - do i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - ipx = ipx + 1 - enddo - enddo - end if - -c csr product - - ipx = ia(1,ipg) - do 70 k = ia(3,ipg), ia(2,ipg+1)-1 - do 60 i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - 60 continue - ipx = ipx + 1 - 70 continue - 200 continue -c - return - end - diff --git a/base/serial/jad/djadmv3.f b/base/serial/jad/djadmv3.f deleted file mode 100644 index 0719a967c..000000000 --- a/base/serial/jad/djadmv3.f +++ /dev/null @@ -1,360 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* PROCEDURAL LOGIC SECTION * -* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * -* DOUBLE PRECISION ZERO * -* PARAMETER (ZERO=0.0D0) * -* DOUBLE PRECISION ACC * -* INTEGER I, J, K, IPX, IPG * -* LOGICAL UNI * -*C .. Executable Statements .. * -*C * -*C * -* IF (DIAG.EQ.'U') THEN * -* DO 10 I = 1, M * -* Y(I) = BETA*Y(I) + ALPHA*X(I) * -* 10 CONTINUE * -* ELSE * -* DO 20 I = 1, M * -* Y(I) = BETA*Y(I) * -* 20 CONTINUE * -* END IF * -* * -* IF (ALPHA.EQ.ZERO) THEN * -* RETURN * -* END IF * -*C * -*C * -*C DO 200 IPG = 1, NG * -* DO 50 K = IA(2,IPG), IA(3,IPG)-1 * -* IPX = IA(1,IPG) * -* DO 40 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* IPX = IPX + 1 * -* 40 CONTINUE * -* 50 CONTINUE * -*C * -*C * -* IPX = IA(1,IPG) * -* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * -* DO 60 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* 60 CONTINUE * -* IPX = IPX + 1 * -* 70 CONTINUE * -* 200 CONTINUE * -*C * -* RETURN * -*C * -*C * -* END * -* * -* * -*********************************************************************** - SUBROUTINE DJADMV3(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, - + X,LDX,BETA,Y,LDY,IERROR) - use psb_const_mod - IMPLICIT NONE - INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR - real(psb_dpk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA - CHARACTER DIAG - real(psb_dpk_) ZERO - PARAMETER (ZERO=0.0D0) - INTEGER I, K, IPX, IPG, I0, IN - INTEGER NPG - integer nb - parameter (nb=3) - real(psb_dpk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), - + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), - + Y12(NB), Y13(NB), Y14(NB), Y15(NB) -c .. Executable Statements .. -c -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb - IERROR=0 - IF (DIAG.EQ.'U') THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = ALPHA*X(I,1:NB) - ENDDO - ELSE - DO 10 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) - 10 CONTINUE - ENDIF - ELSE - IF (BETA.EQ.ZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = 0.D0 - ENDDO - ELSE - DO 20 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) - 20 CONTINUE - END IF - ENDIF - - IF (ALPHA.EQ.ZERO) THEN - RETURN - END IF -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta - - do 200 ipg = 1, ng - k = ia(2,ipg) - npg = ja(k+1)-ja(k) - -c$$$ write(0,*) 'djadmv2:',npg - - if (npg.eq.4) then - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+3, 4 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - - else if (npg.eq.5) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+4, 5 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - - else if (npg.eq.6) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+5, 6 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - - else if (npg.eq.7) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+6, 7 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - - else if (npg.eq.8) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - y7(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+7, 8 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - - else if (npg.eq.16) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - y7(1:nb) = zero - y8(1:nb) = zero - y9(1:nb) = zero - y10(1:nb) = zero - y11(1:nb) = zero - y12(1:nb) = zero - y13(1:nb) = zero - y14(1:nb) = zero - y15(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+15, 16 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) - y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) - y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) - y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) - y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) - y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) - y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) - y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) - y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) - y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) - y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) - y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) - y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) - y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) - y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) - - else - - do k = ia(2,ipg), ia(3,ipg)-1 - ipx = ia(1,ipg) - do i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - ipx = ipx + 1 - enddo - enddo - end if - -c csr product - - ipx = ia(1,ipg) - do 70 k = ia(3,ipg), ia(2,ipg+1)-1 - do 60 i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - 60 continue - ipx = ipx + 1 - 70 continue - 200 continue -c - return - end - diff --git a/base/serial/jad/djadmv4.f b/base/serial/jad/djadmv4.f deleted file mode 100644 index d5cc9eab7..000000000 --- a/base/serial/jad/djadmv4.f +++ /dev/null @@ -1,360 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* PROCEDURAL LOGIC SECTION * -* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * -* DOUBLE PRECISION ZERO * -* PARAMETER (ZERO=0.0D0) * -* DOUBLE PRECISION ACC * -* INTEGER I, J, K, IPX, IPG * -* LOGICAL UNI * -*C .. Executable Statements .. * -*C * -*C * -* IF (DIAG.EQ.'U') THEN * -* DO 10 I = 1, M * -* Y(I) = BETA*Y(I) + ALPHA*X(I) * -* 10 CONTINUE * -* ELSE * -* DO 20 I = 1, M * -* Y(I) = BETA*Y(I) * -* 20 CONTINUE * -* END IF * -* * -* IF (ALPHA.EQ.ZERO) THEN * -* RETURN * -* END IF * -*C * -*C * -*C DO 200 IPG = 1, NG * -* DO 50 K = IA(2,IPG), IA(3,IPG)-1 * -* IPX = IA(1,IPG) * -* DO 40 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* IPX = IPX + 1 * -* 40 CONTINUE * -* 50 CONTINUE * -*C * -*C * -* IPX = IA(1,IPG) * -* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * -* DO 60 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* 60 CONTINUE * -* IPX = IPX + 1 * -* 70 CONTINUE * -* 200 CONTINUE * -*C * -* RETURN * -*C * -*C * -* END * -* * -* * -*********************************************************************** - SUBROUTINE DJADMV4(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, - + X,LDX,BETA,Y,LDY,IERROR) - use psb_const_mod - IMPLICIT NONE - INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR - real(psb_dpk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA - CHARACTER DIAG - real(psb_dpk_) ZERO - PARAMETER (ZERO=0.0D0) - INTEGER I, K, IPX, IPG, I0, IN - INTEGER NPG - integer nb - parameter (nb=4) - real(psb_dpk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), - + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), - + Y12(NB), Y13(NB), Y14(NB), Y15(NB) -c .. Executable Statements .. -c -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb - IERROR=0 - IF (DIAG.EQ.'U') THEN - IF (BETA.EQ.ZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = ALPHA*X(I,1:NB) - ENDDO - ELSE - DO 10 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) - 10 CONTINUE - ENDIF - ELSE - IF (BETA.EQ.ZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = 0.D0 - ENDDO - ELSE - DO 20 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) - 20 CONTINUE - END IF - ENDIF - - IF (ALPHA.EQ.ZERO) THEN - RETURN - END IF -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta - - do 200 ipg = 1, ng - k = ia(2,ipg) - npg = ja(k+1)-ja(k) - -c$$$ write(0,*) 'djadmv2:',npg - - if (npg.eq.4) then - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+3, 4 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - - else if (npg.eq.5) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+4, 5 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - - else if (npg.eq.6) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+5, 6 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - - else if (npg.eq.7) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+6, 7 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - - else if (npg.eq.8) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - y7(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+7, 8 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - - else if (npg.eq.16) then - - ipx = ia(1,ipg) - y0(1:nb) = zero - y1(1:nb) = zero - y2(1:nb) = zero - y3(1:nb) = zero - y4(1:nb) = zero - y5(1:nb) = zero - y6(1:nb) = zero - y7(1:nb) = zero - y8(1:nb) = zero - y9(1:nb) = zero - y10(1:nb) = zero - y11(1:nb) = zero - y12(1:nb) = zero - y13(1:nb) = zero - y14(1:nb) = zero - y15(1:nb) = zero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+15, 16 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) - y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) - y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) - y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) - y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) - y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) - y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) - y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) - y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) - y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) - y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) - y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) - y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) - y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) - y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) - - else - - do k = ia(2,ipg), ia(3,ipg)-1 - ipx = ia(1,ipg) - do i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - ipx = ipx + 1 - enddo - enddo - end if - -c csr product - - ipx = ia(1,ipg) - do 70 k = ia(3,ipg), ia(2,ipg+1)-1 - do 60 i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - 60 continue - ipx = ipx + 1 - 70 continue - 200 continue -c - return - end - diff --git a/base/serial/jad/djadnr.f b/base/serial/jad/djadnr.f deleted file mode 100644 index 287d69eab..000000000 --- a/base/serial/jad/djadnr.f +++ /dev/null @@ -1,90 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute infinity norma for sparse matrix in CSR Format ... - FUNCTION DJADNR(TRANS,M,N,NG,A,KA,JA,IA, - + INFOA,IERROR) - use psb_const_mod - use psb_spmat_type - IMPLICIT NONE - real(psb_dpk_) djadnr -C .. Scalar Arguments .. - INTEGER M,N, IERROR, NG - CHARACTER TRANS -C .. Array Arguments .. - INTEGER KA(*),JA(*),IA(3,*),INFOA(*) - real(psb_dpk_) A(*) -C ... Local Array .. - real(psb_dpk_) NRMI_BLOCK(PSB_MAXJDROWS_) -C ... Local Scalars .. - real(psb_dpk_) NRMI - INTEGER I, K, IPG, NPG, IPX - - IERROR=0 - NRMI = 0.0 - - DO IPG = 1, NG - K = IA(2,IPG) - NPG = JA(K+1)- JA(K) - -C ... Initialize NRMI_BLOCK ... - DO I = 1, NPG - NRMI_BLOCK(I) = 0.0 - ENDDO - - DO K = IA(2,IPG), IA(3,IPG)-1 - IPX = 1 - DO I = JA(K), JA(K+1) - 1 - NRMI_BLOCK(IPX) = NRMI_BLOCK(IPX) + ABS(A(I)) - IPX = IPX + 1 - ENDDO - ENDDO - -C ... CSR Representation ... - - IPX = 1 - DO K = IA(3,IPG), IA(2,IPG+1)-1 - DO I = JA(K), JA(K+1) - 1 - NRMI_BLOCK(IPX) = NRMI_BLOCK(IPX) + ABS(A(I)) - ENDDO - IPX = IPX + 1 - ENDDO - -C ... Compute Max in Block ... - DO I = 1, NPG - IF (NRMI_BLOCK(I).GT.NRMI) THEN - NRMI = NRMI_BLOCK(I) - ENDIF - ENDDO - ENDDO - - DJADNR = NRMI - END diff --git a/base/serial/jad/djadrws.f b/base/serial/jad/djadrws.f deleted file mode 100644 index c9162bf9d..000000000 --- a/base/serial/jad/djadrws.f +++ /dev/null @@ -1,79 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute infinity norma for sparse matrix in CSR Format ... - SUBROUTINE DJADRWS(TRANS,M,N,NG,A,KA,JA,IA, - + INFOA,ROWSUM,IERROR) - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR, NG - CHARACTER TRANS -C .. Array Arguments .. - INTEGER KA(*),JA(*),IA(3,*),INFOA(*) - real(psb_dpk_) A(*), rowsum(*) -C ... Local Scalars .. - real(psb_dpk_) NRMI - INTEGER I, IR, K, IPG, NPG, IPX - - NRMI = 0.0 - IR = 0 - DO IPG = 1, NG - K = IA(2,IPG) - NPG = JA(K+1)- JA(K) - -C ... ... - DO I = 1, NPG - ROWSUM(IR+I) = 0.0 - ENDDO - - DO K = IA(2,IPG), IA(3,IPG)-1 - IPX = 1 - DO I = JA(K), JA(K+1) - 1 - ROWSUM(IR+IPX) = ROWSUM(IR+IPX) + ABS(A(I)) - IPX = IPX + 1 - ENDDO - ENDDO - -C ... CSR Representation ... - - IPX = 1 - DO K = IA(3,IPG), IA(2,IPG+1)-1 - DO I = JA(K), JA(K+1) - 1 - ROWSUM(IR+IPX) = ROWSUM(IR+IPX) + ABS(A(I)) - ENDDO - IPX = IPX + 1 - ENDDO - - IR = IR + NPG - ENDDO - - END diff --git a/base/serial/jad/djadsm.f b/base/serial/jad/djadsm.f deleted file mode 100644 index 2fc6a9c63..000000000 --- a/base/serial/jad/djadsm.f +++ /dev/null @@ -1,139 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE DJADSM(TRANST,M,N,VDIAG,TDIAG,PERMQ,ALPHA,DESCRA, - + AR,JA,IA,PERMP,B,LDB,BETA,C,LDC,WORK) - use psb_const_mod - use psb_error_mod - use psb_string_mod - implicit none -C -C -C .. Scalar Arguments .. - INTEGER LDB, LDC, M, N - CHARACTER TDIAG, TRANST - real(psb_dpk_) ALPHA, BETA -C .. Array Arguments .. - real(psb_dpk_) AR(*), B(LDB,*), C(LDC,*), VDIAG(*), WORK(*) - INTEGER IA(*), JA(*), PERMP(*), PERMQ(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER PIA, PJA, PNG - INTEGER I, K, ERR_ACT - CHARACTER UPLO,UNITD - integer :: debug_level, debug_unit - CHARACTER*20 NAME - INTEGER INT_VAL(5),ierror -C .. Executable Statements .. -C - NAME = 'DJADSM' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF((ALPHA.NE.1.D0) .OR. (BETA.NE.0.D0))then - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - UPLO = '?' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' -C - IF (UPLO.EQ.'?') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - UNITD=DESCRA(3:3) -C -C B = INV(A)*B OR B=INV(A')*B -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': entry',m,n - - IF (psb_toupper(TDIAG).EQ.'R') THEN - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': Right Scale' - DO I = 1, N - DO K = 1, M - B(K,I) = B(K,I)*VDIAG(K) - ENDDO - ENDDO - END IF - - PNG = IA(1) - PIA = IA(2) - PJA = IA(3) - - DO I = 1, N - CALL DJADSV(UNITD,M,IA(PNG), - + AR,JA,IA(PIA),IA(PJA),B(1,I),C(1,I),IERROR) - ENDDO - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - - IF (psb_toupper(TDIAG).EQ.'L') THEN - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': Left Scale' - DO I = 1, N - DO K = 1, M - C(K,I) = C(K,I)*VDIAG(K) - ENDDO - ENDDO - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/jad/djadsv.f b/base/serial/jad/djadsv.f deleted file mode 100644 index d14f0cb26..000000000 --- a/base/serial/jad/djadsv.f +++ /dev/null @@ -1,88 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C This routine compute only the casew with Unit diagonal ... - SUBROUTINE DJADSV(UNITD,NROW,NG,A,KA,IA,JA,X,Y,IERROR) - use psb_const_mod - implicit none - real(psb_dpk_) A(*),X(*),Y(*) - integer IA(3,*),JA(*),KA(*),nrow,ng,i,j,k,ipg,ip2,ipx - CHARACTER UNITD - INTEGER IERROR - - IERROR=0 - - IF (UNITD.EQ.'U') THEN - - IF (NG.EQ.0) THEN - DO I = 1, NROW - Y(I) = X(I) - ENDDO - ENDIF - - DO IPG=1,NG - DO I = IA(1,IPG),IA(1,IPG+1)-1 - Y(I) = X(I) - END DO -* -* LOOP ON COLUMNS -* --------------- -* - IP2 = IA(2,IPG) - DO K = IP2, IA(3,IPG)-1 - IPX = IA(1,IPG) - DO I = JA(K), JA(K+1)-1 - Y(IPX) = Y(IPX) - A(I)*Y(KA(I)) - IPX = IPX+1 - ENDDO - ENDDO -* -* -* LOOP ON ROWS -* --------------- -* - IPX = IA(1,IPG) - DO K = IA(3,IPG), IA(2,IPG+1)-1 - DO I = JA(K), JA(K+1)-1 - Y(IPX) = Y(IPX) - A(I)*Y(KA(I)) - ENDDO - IPX = IPX + 1 - ENDDO - -**************************************** - END DO !END LOOP ON IPG=1,NG -**************************************** - ELSE - WRITE(0,*) 'ERROR in DJADSV' - ENDIF - RETURN - END - diff --git a/base/serial/jad/djdnrmi.f b/base/serial/jad/djdnrmi.f deleted file mode 100644 index da064941c..000000000 --- a/base/serial/jad/djdnrmi.f +++ /dev/null @@ -1,61 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute infinity norm for sparse matrix in CSR Format ... - FUNCTION DJDNRMI(TRANS,M,N,DESCRA,A,JA,IA, - + INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_dpk_) djdnrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER JA(*),IA(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_dpk_) A(*) -C .. Local scalars .. - INTEGER PNG, PIA, PJA -C .. External routines .. - real(psb_dpk_) DJADNR - EXTERNAL DJADNR - - IERROR=0 - PNG = IA(1) - PIA = IA(2) - PJA = IA(3) - djdnrmi = 0.d0 - IF (DESCRA(1:1).EQ.'G') THEN - DJDNRMI = DJADNR(TRANS,M,N,IA(PNG), - + A,JA,IA(PJA),IA(PIA), - + INFOA,IERROR) - ENDIF - END diff --git a/base/serial/jad/djdrws.f b/base/serial/jad/djdrws.f deleted file mode 100644 index eb5b123f0..000000000 --- a/base/serial/jad/djdrws.f +++ /dev/null @@ -1,62 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute infinity norm for sparse matrix in CSR Format ... - SUBROUTINE DJDRWS(TRANS,M,N,DESCRA,A,JA,IA, - + INFOA,ROWSUM,IERROR) - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER JA(*),IA(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_dpk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER PNG, PIA, PJA -C .. External routines .. - real(psb_dpk_) DJADNR - EXTERNAL DJADNR - - IERROR = 0 - PNG = IA(1) - PIA = IA(2) - PJA = IA(3) - - IF (DESCRA(1:1).EQ.'G') THEN - CALL DJADRWS(TRANS,M,N,IA(PNG), - + A,JA,IA(PJA),IA(PIA), - + INFOA,ROWSUM,IERROR) - ELSE - IERROR = 3011 - ENDIF - END diff --git a/base/serial/jad/sjadmm.f b/base/serial/jad/sjadmm.f deleted file mode 100644 index 9ec434823..000000000 --- a/base/serial/jad/sjadmm.f +++ /dev/null @@ -1,144 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SJADMM(TRANSA,M,K,N,ALPHA,DESCRA,AR, - * JA,IA,B,LDB,BETA,C,LDC,WORK,IERROR) - use psb_const_mod - IMPLICIT NONE -C -C -C .. Scalar Arguments .. - real(psb_spk_) ALPHA, BETA - INTEGER K, LDB, LDC, M, N,IERROR - CHARACTER TRANSA -C .. Array Arguments .. - real(psb_spk_) AR(*), B(LDB,*), C(LDC,*), WORK(*) - INTEGER IA(*), JA(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - integer PIA, PJA, PNG - INTEGER I, J, KB,NB, ERR_ACT - CHARACTER DIAG, TRANS -c .. Local Arrays .. - CHARACTER*20 NAME - INTEGER INT_VAL(5) -C .. Executable Statements .. -C - - NAME = 'DJADMM\0' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - - TRANS = TRANSA - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'U') TRANS = 'U' - IF (DESCRA(1:1).EQ.'S' .AND. DESCRA(2:2).EQ.'L') TRANS = 'L' - IF (DESCRA(1:1).EQ.'D') THEN - IF (DESCRA(3:3).EQ.'U') THEN - DO 40 I = 1, K - DO 20 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*B(J,I) - 20 CONTINUE - 40 CONTINUE - ELSE - DO 80 I = 1, K - DO 60 J = 1, M - C(J,I) = BETA*C(J,I) + ALPHA*AR(J)*B(J,I) - 60 CONTINUE - 80 CONTINUE - END IF - RETURN - END IF - IF (TRANS.EQ.'T'.or.TRANS.EQ.'C') THEN - IERROR = 3015 - RETURN - ENDIF -C - IF (DESCRA(3:3).EQ.'N') DIAG = 'N' - IF (DESCRA(3:3).EQ.'U') DIAG = 'U' - PNG = IA(1) - PIA = IA(2) - PJA = IA(3) -* write(6,*)'M N K',m,n,k - - NB = 4 - KB = MOD(K,NB) - - SELECT CASE(KB) - CASE (1) - IF (K==1) THEN - CALL SJADMV(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,1),BETA,C(1,1),IERROR) - ELSE - CALL SJADMV2(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) - CALL SJADMV3(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,3),LDB,BETA,C(1,3),LDC,IERROR) - KB = KB + 4 - ENDIF - CASE(2) - CALL SJADMV2(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) - CASE(3) - CALL SJADMV3(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,1),LDB,BETA,C(1,1),LDC,IERROR) - - END SELECT - - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - DO I=KB+1,K,NB - CALL SJADMV4(DIAG,M,N,ALPHA,IA(PNG), - + AR,JA,IA(PJA),IA(PIA),B(1,I),LDB,BETA,C(1,I),LDC,IERROR) - END DO - - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/jad/sjadmv.f b/base/serial/jad/sjadmv.f deleted file mode 100644 index 345e4e5c4..000000000 --- a/base/serial/jad/sjadmv.f +++ /dev/null @@ -1,351 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* PROCEDURAL LOGIC SECTION * -* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * -* DOUBLE PRECISION ZERO * -* PARAMETER (ZERO=0.0D0) * -* DOUBLE PRECISION ACC * -* INTEGER I, J, K, IPX, IPG * -* LOGICAL UNI * -*C .. Executable Statements .. * -*C * -*C * -* IF (DIAG.EQ.'U') THEN * -* DO 10 I = 1, M * -* Y(I) = BETA*Y(I) + ALPHA*X(I) * -* 10 CONTINUE * -* ELSE * -* DO 20 I = 1, M * -* Y(I) = BETA*Y(I) * -* 20 CONTINUE * -* END IF * -* * -* IF (ALPHA.EQ.ZERO) THEN * -* RETURN * -* END IF * -*C * -*C * -*C DO 200 IPG = 1, NG * -* DO 50 K = IA(2,IPG), IA(3,IPG)-1 * -* IPX = IA(1,IPG) * -* DO 40 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* IPX = IPX + 1 * -* 40 CONTINUE * -* 50 CONTINUE * -*C * -*C * -* IPX = IA(1,IPG) * -* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * -* DO 60 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* 60 CONTINUE * -* IPX = IPX + 1 * -* 70 CONTINUE * -* 200 CONTINUE * -*C * -* RETURN * -*C * -*C * -* END * -* * -* * -*********************************************************************** - SUBROUTINE SJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X, - + BETA,Y,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_spk_) A(*),X(*),Y(*),ALPHA,BETA - INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,IERROR - CHARACTER DIAG - INTEGER I, K, IPX, IPG, I0, IN - INTEGER NPG - real(psb_spk_) Y0, Y1, Y2, Y3, Y4, Y5, Y6, Y7, - + Y8, Y9, Y10, Y11, Y12, Y13, Y14, Y15 -c .. Executable Statements .. -c -c - IERROR=0 - IF (DIAG.EQ.'U') THEN - IF (BETA.EQ.SZERO) THEN - DO I = 1, NROW - Y(I) = ALPHA*X(I) - ENDDO - ELSE - DO 10 I = 1, NROW - Y(I) = BETA*Y(I) + ALPHA*X(I) - 10 CONTINUE - ENDIF - ELSE - IF (BETA.EQ.SZERO) THEN - DO I = 1, NROW - Y(I) = 0.D0 - ENDDO - ELSE - DO 20 I = 1, NROW - Y(I) = BETA*Y(I) - 20 CONTINUE - END IF - ENDIF - - IF (ALPHA.EQ.SZERO) THEN - RETURN - END IF -c -c - DO 200 IPG = 1, NG - K = IA(2,IPG) - NPG = JA(K+1)-JA(K) - - IF (NPG.EQ.4) THEN - IPX = IA(1,IPG) - Y0 = SZERO - Y1 = SZERO - Y2 = SZERO - Y3 = SZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+3, 4 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - - ELSE IF (NPG.EQ.5) THEN - - IPX = IA(1,IPG) - Y0 = SZERO - Y1 = SZERO - Y2 = SZERO - Y3 = SZERO - Y4 = SZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+4, 5 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - - ELSE IF (NPG.EQ.6) THEN - - IPX = IA(1,IPG) - Y0 = SZERO - Y1 = SZERO - Y2 = SZERO - Y3 = SZERO - Y4 = SZERO - Y5 = SZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+5, 6 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - Y5 = Y5 + A(I+5)*X(KA(I+5)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 - - ELSE IF (NPG.EQ.7) THEN - - IPX = IA(1,IPG) - Y0 = SZERO - Y1 = SZERO - Y2 = SZERO - Y3 = SZERO - Y4 = SZERO - Y5 = SZERO - Y6 = SZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+6, 7 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - Y5 = Y5 + A(I+5)*X(KA(I+5)) - Y6 = Y6 + A(I+6)*X(KA(I+6)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 - Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 - - ELSE IF (NPG.EQ.8) THEN - - IPX = IA(1,IPG) - Y0 = SZERO - Y1 = SZERO - Y2 = SZERO - Y3 = SZERO - Y4 = SZERO - Y5 = SZERO - Y6 = SZERO - Y7 = SZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+7, 8 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - Y5 = Y5 + A(I+5)*X(KA(I+5)) - Y6 = Y6 + A(I+6)*X(KA(I+6)) - Y7 = Y7 + A(I+7)*X(KA(I+7)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 - Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 - Y(IPX+7) = Y(IPX+7) + ALPHA*Y7 - - ELSE IF (NPG.EQ.16) THEN - - IPX = IA(1,IPG) - Y0 = SZERO - Y1 = SZERO - Y2 = SZERO - Y3 = SZERO - Y4 = SZERO - Y5 = SZERO - Y6 = SZERO - Y7 = SZERO - Y8 = SZERO - Y9 = SZERO - Y10 = SZERO - Y11 = SZERO - Y12 = SZERO - Y13 = SZERO - Y14 = SZERO - Y15 = SZERO - K = IA(2,IPG) - I0 = JA(K) - K = IA(3,IPG)-1 - IN = JA(K) - DO I = I0, IN+15, 16 - Y0 = Y0 + A(I+0)*X(KA(I+0)) - Y1 = Y1 + A(I+1)*X(KA(I+1)) - Y2 = Y2 + A(I+2)*X(KA(I+2)) - Y3 = Y3 + A(I+3)*X(KA(I+3)) - Y4 = Y4 + A(I+4)*X(KA(I+4)) - Y5 = Y5 + A(I+5)*X(KA(I+5)) - Y6 = Y6 + A(I+6)*X(KA(I+6)) - Y7 = Y7 + A(I+7)*X(KA(I+7)) - Y8 = Y8 + A(I+8)*X(KA(I+8)) - Y9 = Y9 + A(I+9)*X(KA(I+9)) - Y10 = Y10 + A(I+10)*X(KA(I+10)) - Y11 = Y11 + A(I+11)*X(KA(I+11)) - Y12 = Y12 + A(I+12)*X(KA(I+12)) - Y13 = Y13 + A(I+13)*X(KA(I+13)) - Y14 = Y14 + A(I+14)*X(KA(I+14)) - Y15 = Y15 + A(I+15)*X(KA(I+15)) - ENDDO - Y(IPX+0) = Y(IPX+0) + ALPHA*Y0 - Y(IPX+1) = Y(IPX+1) + ALPHA*Y1 - Y(IPX+2) = Y(IPX+2) + ALPHA*Y2 - Y(IPX+3) = Y(IPX+3) + ALPHA*Y3 - Y(IPX+4) = Y(IPX+4) + ALPHA*Y4 - Y(IPX+5) = Y(IPX+5) + ALPHA*Y5 - Y(IPX+6) = Y(IPX+6) + ALPHA*Y6 - Y(IPX+7) = Y(IPX+7) + ALPHA*Y7 - Y(IPX+8) = Y(IPX+8) + ALPHA*Y8 - Y(IPX+9) = Y(IPX+9) + ALPHA*Y9 - Y(IPX+10) = Y(IPX+10) + ALPHA*Y10 - Y(IPX+11) = Y(IPX+11) + ALPHA*Y11 - Y(IPX+12) = Y(IPX+12) + ALPHA*Y12 - Y(IPX+13) = Y(IPX+13) + ALPHA*Y13 - Y(IPX+14) = Y(IPX+14) + ALPHA*Y14 - Y(IPX+15) = Y(IPX+15) + ALPHA*Y15 - - ELSE - - DO K = IA(2,IPG), IA(3,IPG)-1 - IPX = IA(1,IPG) - DO I = JA(K), JA(K+1) - 1 - Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) - IPX = IPX + 1 - ENDDO - ENDDO - END IF - -c CSR Product - - IPX = IA(1,IPG) - DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 - DO 60 I = JA(K), JA(K+1) - 1 - Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) - 60 CONTINUE - IPX = IPX + 1 - 70 CONTINUE - 200 CONTINUE -c - RETURN - END - diff --git a/base/serial/jad/sjadmv2.f b/base/serial/jad/sjadmv2.f deleted file mode 100644 index 0d0efea4d..000000000 --- a/base/serial/jad/sjadmv2.f +++ /dev/null @@ -1,358 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* PROCEDURAL LOGIC SECTION * -* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * -* DOUBLE PRECISION ZERO * -* PARAMETER (ZERO=0.0D0) * -* DOUBLE PRECISION ACC * -* INTEGER I, J, K, IPX, IPG * -* LOGICAL UNI * -*C .. Executable Statements .. * -*C * -*C * -* IF (DIAG.EQ.'U') THEN * -* DO 10 I = 1, M * -* Y(I) = BETA*Y(I) + ALPHA*X(I) * -* 10 CONTINUE * -* ELSE * -* DO 20 I = 1, M * -* Y(I) = BETA*Y(I) * -* 20 CONTINUE * -* END IF * -* * -* IF (ALPHA.EQ.ZERO) THEN * -* RETURN * -* END IF * -*C * -*C * -*C DO 200 IPG = 1, NG * -* DO 50 K = IA(2,IPG), IA(3,IPG)-1 * -* IPX = IA(1,IPG) * -* DO 40 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* IPX = IPX + 1 * -* 40 CONTINUE * -* 50 CONTINUE * -*C * -*C * -* IPX = IA(1,IPG) * -* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * -* DO 60 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* 60 CONTINUE * -* IPX = IPX + 1 * -* 70 CONTINUE * -* 200 CONTINUE * -*C * -* RETURN * -*C * -*C * -* END * -* * -* * -*********************************************************************** - SUBROUTINE SJADMV2(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, - + X,LDX,BETA,Y,LDY, IERROR) - use psb_const_mod - IMPLICIT NONE - INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR - real(psb_spk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA - CHARACTER DIAG - INTEGER I, J, K, IPX, IPG, I0, IN - INTEGER NPG - integer nb - parameter (nb=2) - real(psb_spk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), - + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), - + Y12(NB), Y13(NB), Y14(NB), Y15(NB) -c .. Executable Statements .. -c -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb - IERROR=0 - IF (DIAG.EQ.'U') THEN - IF (BETA.EQ.SZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = ALPHA*X(I,1:NB) - ENDDO - ELSE - DO 10 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) - 10 CONTINUE - ENDIF - ELSE - IF (BETA.EQ.SZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = 0.D0 - ENDDO - ELSE - DO 20 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) - 20 CONTINUE - END IF - ENDIF - - IF (ALPHA.EQ.SZERO) THEN - RETURN - END IF -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta - - do 200 ipg = 1, ng - k = ia(2,ipg) - npg = ja(k+1)-ja(k) - -c$$$ write(0,*) 'djadmv2:',npg - - if (npg.eq.4) then - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+3, 4 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - - else if (npg.eq.5) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+4, 5 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - - else if (npg.eq.6) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+5, 6 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - - else if (npg.eq.7) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+6, 7 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - - else if (npg.eq.8) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - y7(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+7, 8 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - - else if (npg.eq.16) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - y7(1:nb) = szero - y8(1:nb) = szero - y9(1:nb) = szero - y10(1:nb) = szero - y11(1:nb) = szero - y12(1:nb) = szero - y13(1:nb) = szero - y14(1:nb) = szero - y15(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+15, 16 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) - y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) - y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) - y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) - y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) - y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) - y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) - y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) - y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) - y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) - y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) - y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) - y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) - y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) - y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) - - else - - do k = ia(2,ipg), ia(3,ipg)-1 - ipx = ia(1,ipg) - do i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - ipx = ipx + 1 - enddo - enddo - end if - -c csr product - - ipx = ia(1,ipg) - do 70 k = ia(3,ipg), ia(2,ipg+1)-1 - do 60 i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - 60 continue - ipx = ipx + 1 - 70 continue - 200 continue -c - return - end - diff --git a/base/serial/jad/sjadmv3.f b/base/serial/jad/sjadmv3.f deleted file mode 100644 index 111fe7b48..000000000 --- a/base/serial/jad/sjadmv3.f +++ /dev/null @@ -1,358 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* PROCEDURAL LOGIC SECTION * -* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * -* DOUBLE PRECISION ZERO * -* PARAMETER (ZERO=0.0D0) * -* DOUBLE PRECISION ACC * -* INTEGER I, J, K, IPX, IPG * -* LOGICAL UNI * -*C .. Executable Statements .. * -*C * -*C * -* IF (DIAG.EQ.'U') THEN * -* DO 10 I = 1, M * -* Y(I) = BETA*Y(I) + ALPHA*X(I) * -* 10 CONTINUE * -* ELSE * -* DO 20 I = 1, M * -* Y(I) = BETA*Y(I) * -* 20 CONTINUE * -* END IF * -* * -* IF (ALPHA.EQ.ZERO) THEN * -* RETURN * -* END IF * -*C * -*C * -*C DO 200 IPG = 1, NG * -* DO 50 K = IA(2,IPG), IA(3,IPG)-1 * -* IPX = IA(1,IPG) * -* DO 40 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* IPX = IPX + 1 * -* 40 CONTINUE * -* 50 CONTINUE * -*C * -*C * -* IPX = IA(1,IPG) * -* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * -* DO 60 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* 60 CONTINUE * -* IPX = IPX + 1 * -* 70 CONTINUE * -* 200 CONTINUE * -*C * -* RETURN * -*C * -*C * -* END * -* * -* * -*********************************************************************** - SUBROUTINE SJADMV3(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, - + X,LDX,BETA,Y,LDY, IERROR) - use psb_const_mod - IMPLICIT NONE - INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR - real(psb_spk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA - CHARACTER DIAG - INTEGER I, J, K, IPX, IPG, I0, IN - INTEGER NPG - integer nb - parameter (nb=3) - real(psb_spk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), - + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), - + Y12(NB), Y13(NB), Y14(NB), Y15(NB) -c .. Executable Statements .. -c -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb - IERROR=0 - IF (DIAG.EQ.'U') THEN - IF (BETA.EQ.SZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = ALPHA*X(I,1:NB) - ENDDO - ELSE - DO 10 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) - 10 CONTINUE - ENDIF - ELSE - IF (BETA.EQ.SZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = 0.D0 - ENDDO - ELSE - DO 20 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) - 20 CONTINUE - END IF - ENDIF - - IF (ALPHA.EQ.SZERO) THEN - RETURN - END IF -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta - - do 200 ipg = 1, ng - k = ia(2,ipg) - npg = ja(k+1)-ja(k) - -c$$$ write(0,*) 'djadmv2:',npg - - if (npg.eq.4) then - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+3, 4 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - - else if (npg.eq.5) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+4, 5 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - - else if (npg.eq.6) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+5, 6 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - - else if (npg.eq.7) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+6, 7 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - - else if (npg.eq.8) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - y7(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+7, 8 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - - else if (npg.eq.16) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - y7(1:nb) = szero - y8(1:nb) = szero - y9(1:nb) = szero - y10(1:nb) = szero - y11(1:nb) = szero - y12(1:nb) = szero - y13(1:nb) = szero - y14(1:nb) = szero - y15(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+15, 16 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) - y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) - y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) - y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) - y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) - y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) - y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) - y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) - y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) - y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) - y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) - y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) - y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) - y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) - y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) - - else - - do k = ia(2,ipg), ia(3,ipg)-1 - ipx = ia(1,ipg) - do i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - ipx = ipx + 1 - enddo - enddo - end if - -c csr product - - ipx = ia(1,ipg) - do 70 k = ia(3,ipg), ia(2,ipg+1)-1 - do 60 i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - 60 continue - ipx = ipx + 1 - 70 continue - 200 continue -c - return - end - diff --git a/base/serial/jad/sjadmv4.f b/base/serial/jad/sjadmv4.f deleted file mode 100644 index 19c17348d..000000000 --- a/base/serial/jad/sjadmv4.f +++ /dev/null @@ -1,358 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -*********************************************************************** -* PROCEDURAL LOGIC SECTION * -* SUBROUTINE DJADMV (DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA,X,BETA,Y) * -* DOUBLE PRECISION ZERO * -* PARAMETER (ZERO=0.0D0) * -* DOUBLE PRECISION ACC * -* INTEGER I, J, K, IPX, IPG * -* LOGICAL UNI * -*C .. Executable Statements .. * -*C * -*C * -* IF (DIAG.EQ.'U') THEN * -* DO 10 I = 1, M * -* Y(I) = BETA*Y(I) + ALPHA*X(I) * -* 10 CONTINUE * -* ELSE * -* DO 20 I = 1, M * -* Y(I) = BETA*Y(I) * -* 20 CONTINUE * -* END IF * -* * -* IF (ALPHA.EQ.ZERO) THEN * -* RETURN * -* END IF * -*C * -*C * -*C DO 200 IPG = 1, NG * -* DO 50 K = IA(2,IPG), IA(3,IPG)-1 * -* IPX = IA(1,IPG) * -* DO 40 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* IPX = IPX + 1 * -* 40 CONTINUE * -* 50 CONTINUE * -*C * -*C * -* IPX = IA(1,IPG) * -* DO 70 K = IA(3,IPG), IA(2,IPG+1)-1 * -* DO 60 I = JA(K), JA(K+1) - 1 * -* Y(IPX) = Y(IPX) + ALPHA*A(I)*X(KA(I)) * -* 60 CONTINUE * -* IPX = IPX + 1 * -* 70 CONTINUE * -* 200 CONTINUE * -*C * -* RETURN * -*C * -*C * -* END * -* * -* * -*********************************************************************** - SUBROUTINE SJADMV4(DIAG,NROW,NCOL,ALPHA,NG,A,KA,JA,IA, - + X,LDX,BETA,Y,LDY, IERROR) - use psb_const_mod - IMPLICIT NONE - INTEGER IA(3,*),KA(*),JA(*),NCOL,NROW,NG,LDX,LDY,IERROR - real(psb_spk_) A(*),X(LDX,*),Y(LDY,*),ALPHA,BETA - CHARACTER DIAG - INTEGER I, J, K, IPX, IPG, I0, IN - INTEGER NPG - integer nb - parameter (nb=4) - real(psb_spk_) Y0(NB), Y1(NB), Y2(NB), Y3(NB), Y4(NB), - + Y5(NB), Y6(NB), Y7(NB), Y8(NB), Y9(NB), Y10(NB), Y11(NB), - + Y12(NB), Y13(NB), Y14(NB), Y15(NB) -c .. Executable Statements .. -c -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta,nb - IERROR=0 - IF (DIAG.EQ.'U') THEN - IF (BETA.EQ.SZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = ALPHA*X(I,1:NB) - ENDDO - ELSE - DO 10 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) + ALPHA*X(I,1:NB) - 10 CONTINUE - ENDIF - ELSE - IF (BETA.EQ.SZERO) THEN - DO I = 1, NROW - Y(I,1:NB) = 0.D0 - ENDDO - ELSE - DO 20 I = 1, NROW - Y(I,1:NB) = BETA*Y(I,1:NB) - 20 CONTINUE - END IF - ENDIF - - IF (ALPHA.EQ.SZERO) THEN - RETURN - END IF -c -c$$$ write(0,*) 'djadmv2:',diag,alpha,beta - - do 200 ipg = 1, ng - k = ia(2,ipg) - npg = ja(k+1)-ja(k) - -c$$$ write(0,*) 'djadmv2:',npg - - if (npg.eq.4) then - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+3, 4 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - - else if (npg.eq.5) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+4, 5 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - - else if (npg.eq.6) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+5, 6 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - - else if (npg.eq.7) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+6, 7 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - - else if (npg.eq.8) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - y7(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+7, 8 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - - else if (npg.eq.16) then - - ipx = ia(1,ipg) - y0(1:nb) = szero - y1(1:nb) = szero - y2(1:nb) = szero - y3(1:nb) = szero - y4(1:nb) = szero - y5(1:nb) = szero - y6(1:nb) = szero - y7(1:nb) = szero - y8(1:nb) = szero - y9(1:nb) = szero - y10(1:nb) = szero - y11(1:nb) = szero - y12(1:nb) = szero - y13(1:nb) = szero - y14(1:nb) = szero - y15(1:nb) = szero - k = ia(2,ipg) - i0 = ja(k) - k = ia(3,ipg)-1 - in = ja(k) - do i = i0, in+15, 16 - y0(1:nb) = y0(1:nb) + a(i+0)*x(ka(i+0),1:nb) - y1(1:nb) = y1(1:nb) + a(i+1)*x(ka(i+1),1:nb) - y2(1:nb) = y2(1:nb) + a(i+2)*x(ka(i+2),1:nb) - y3(1:nb) = y3(1:nb) + a(i+3)*x(ka(i+3),1:nb) - y4(1:nb) = y4(1:nb) + a(i+4)*x(ka(i+4),1:nb) - y5(1:nb) = y5(1:nb) + a(i+5)*x(ka(i+5),1:nb) - y6(1:nb) = y6(1:nb) + a(i+6)*x(ka(i+6),1:nb) - y7(1:nb) = y7(1:nb) + a(i+7)*x(ka(i+7),1:nb) - y8(1:nb) = y8(1:nb) + a(i+8)*x(ka(i+8),1:nb) - y9(1:nb) = y9(1:nb) + a(i+9)*x(ka(i+9),1:nb) - y10(1:nb) = y10(1:nb) + a(i+10)*x(ka(i+10),1:nb) - y11(1:nb) = y11(1:nb) + a(i+11)*x(ka(i+11),1:nb) - y12(1:nb) = y12(1:nb) + a(i+12)*x(ka(i+12),1:nb) - y13(1:nb) = y13(1:nb) + a(i+13)*x(ka(i+13),1:nb) - y14(1:nb) = y14(1:nb) + a(i+14)*x(ka(i+14),1:nb) - y15(1:nb) = y15(1:nb) + a(i+15)*x(ka(i+15),1:nb) - enddo - y(ipx+0,1:nb) = y(ipx+0,1:nb) + alpha*y0(1:nb) - y(ipx+1,1:nb) = y(ipx+1,1:nb) + alpha*y1(1:nb) - y(ipx+2,1:nb) = y(ipx+2,1:nb) + alpha*y2(1:nb) - y(ipx+3,1:nb) = y(ipx+3,1:nb) + alpha*y3(1:nb) - y(ipx+4,1:nb) = y(ipx+4,1:nb) + alpha*y4(1:nb) - y(ipx+5,1:nb) = y(ipx+5,1:nb) + alpha*y5(1:nb) - y(ipx+6,1:nb) = y(ipx+6,1:nb) + alpha*y6(1:nb) - y(ipx+7,1:nb) = y(ipx+7,1:nb) + alpha*y7(1:nb) - y(ipx+8,1:nb) = y(ipx+8,1:nb) + alpha*y8(1:nb) - y(ipx+9,1:nb) = y(ipx+9,1:nb) + alpha*y9(1:nb) - y(ipx+10,1:nb) = y(ipx+10,1:nb) + alpha*y10(1:nb) - y(ipx+11,1:nb) = y(ipx+11,1:nb) + alpha*y11(1:nb) - y(ipx+12,1:nb) = y(ipx+12,1:nb) + alpha*y12(1:nb) - y(ipx+13,1:nb) = y(ipx+13,1:nb) + alpha*y13(1:nb) - y(ipx+14,1:nb) = y(ipx+14,1:nb) + alpha*y14(1:nb) - y(ipx+15,1:nb) = y(ipx+15,1:nb) + alpha*y15(1:nb) - - else - - do k = ia(2,ipg), ia(3,ipg)-1 - ipx = ia(1,ipg) - do i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - ipx = ipx + 1 - enddo - enddo - end if - -c csr product - - ipx = ia(1,ipg) - do 70 k = ia(3,ipg), ia(2,ipg+1)-1 - do 60 i = ja(k), ja(k+1) - 1 - y(ipx,1:nb) = y(ipx,1:nb) + alpha*a(i)*x(ka(i),1:nb) - 60 continue - ipx = ipx + 1 - 70 continue - 200 continue -c - return - end - diff --git a/base/serial/jad/sjadnr.f b/base/serial/jad/sjadnr.f deleted file mode 100644 index 6225172e5..000000000 --- a/base/serial/jad/sjadnr.f +++ /dev/null @@ -1,90 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute infinity norma for sparse matrix in CSR Format ... - FUNCTION SJADNR(TRANS,M,N,NG,A,KA,JA,IA, - + INFOA,IERROR) - use psb_const_mod - use psb_spmat_type - IMPLICIT NONE - real(psb_spk_) sjadnr -C .. Scalar Arguments .. - INTEGER M,N, IERROR, NG - CHARACTER TRANS -C .. Array Arguments .. - INTEGER KA(*),JA(*),IA(3,*),INFOA(*) - real(psb_spk_) A(*) -C ... Local Array .. - real(psb_spk_) NRMI_BLOCK(PSB_MAXJDROWS_) -C ... Local Scalars .. - real(psb_spk_) NRMI - INTEGER I, K, IPG, NPG, IPX - - IERROR=0 - NRMI = 0.0 - - DO IPG = 1, NG - K = IA(2,IPG) - NPG = JA(K+1)- JA(K) - -C ... Initialize NRMI_BLOCK ... - DO I = 1, NPG - NRMI_BLOCK(I) = 0.0 - ENDDO - - DO K = IA(2,IPG), IA(3,IPG)-1 - IPX = 1 - DO I = JA(K), JA(K+1) - 1 - NRMI_BLOCK(IPX) = NRMI_BLOCK(IPX) + ABS(A(I)) - IPX = IPX + 1 - ENDDO - ENDDO - -C ... CSR Representation ... - - IPX = 1 - DO K = IA(3,IPG), IA(2,IPG+1)-1 - DO I = JA(K), JA(K+1) - 1 - NRMI_BLOCK(IPX) = NRMI_BLOCK(IPX) + ABS(A(I)) - ENDDO - IPX = IPX + 1 - ENDDO - -C ... Compute Max in Block ... - DO I = 1, NPG - IF (NRMI_BLOCK(I).GT.NRMI) THEN - NRMI = NRMI_BLOCK(I) - ENDIF - ENDDO - ENDDO - - SJADNR = NRMI - END diff --git a/base/serial/jad/sjadrws.f b/base/serial/jad/sjadrws.f deleted file mode 100644 index ea2763867..000000000 --- a/base/serial/jad/sjadrws.f +++ /dev/null @@ -1,79 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute infinity norma for sparse matrix in CSR Format ... - SUBROUTINE SJADRWS(TRANS,M,N,NG,A,KA,JA,IA, - + INFOA,ROWSUM,IERROR) - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR, NG - CHARACTER TRANS -C .. Array Arguments .. - INTEGER KA(*),JA(*),IA(3,*),INFOA(*) - real(psb_spk_) A(*), rowsum(*) -C ... Local Scalars .. - real(psb_spk_) NRMI - INTEGER I, IR, K, IPG, NPG, IPX - - NRMI = 0.0 - IR = 0 - DO IPG = 1, NG - K = IA(2,IPG) - NPG = JA(K+1)- JA(K) - -C ... ... - DO I = 1, NPG - ROWSUM(IR+I) = 0.0 - ENDDO - - DO K = IA(2,IPG), IA(3,IPG)-1 - IPX = 1 - DO I = JA(K), JA(K+1) - 1 - ROWSUM(IR+IPX) = ROWSUM(IR+IPX) + ABS(A(I)) - IPX = IPX + 1 - ENDDO - ENDDO - -C ... CSR Representation ... - - IPX = 1 - DO K = IA(3,IPG), IA(2,IPG+1)-1 - DO I = JA(K), JA(K+1) - 1 - ROWSUM(IR+IPX) = ROWSUM(IR+IPX) + ABS(A(I)) - ENDDO - IPX = IPX + 1 - ENDDO - - IR = IR + NPG - ENDDO - - END diff --git a/base/serial/jad/sjadsm.f b/base/serial/jad/sjadsm.f deleted file mode 100644 index 77f5ee0c9..000000000 --- a/base/serial/jad/sjadsm.f +++ /dev/null @@ -1,139 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C - SUBROUTINE SJADSM(TRANST,M,N,VDIAG,TDIAG,PERMQ,ALPHA,DESCRA, - + AR,JA,IA,PERMP,B,LDB,BETA,C,LDC,WORK) - use psb_const_mod - use psb_error_mod - use psb_string_mod - implicit none -C -C -C .. Scalar Arguments .. - INTEGER LDB, LDC, M, N - CHARACTER TDIAG, TRANST - real(psb_spk_) ALPHA, BETA -C .. Array Arguments .. - real(psb_spk_) AR(*), B(LDB,*), C(LDC,*), VDIAG(*), WORK(*) - INTEGER IA(*), JA(*), PERMP(*), PERMQ(*) - CHARACTER DESCRA*11 -C .. Local Scalars .. - INTEGER PIA, PJA, PNG - INTEGER I, K, ERR_ACT - CHARACTER UPLO,UNITD - integer :: debug_level, debug_unit - CHARACTER*20 NAME - INTEGER INT_VAL(5),ierror -C .. Executable Statements .. -C - NAME = 'DJADSM' - IERROR = 0 - CALL FCPSB_ERRACTIONSAVE(ERR_ACT) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - IF((ALPHA.NE.sone) .OR. (BETA.NE.szero))then - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - ENDIF - UPLO = '?' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'U') UPLO = 'U' - IF (psb_toupper(DESCRA(1:1)).EQ.'T' .AND. - + psb_toupper(DESCRA(2:2)).EQ.'L') UPLO = 'L' -C - IF (UPLO.EQ.'?') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - - IF (psb_toupper(DESCRA(3:3)).NE.'U') THEN - IERROR=5 - CALL FCPSB_ERRPUSH(IERROR,NAME,INT_VAL) - GOTO 9999 - END IF - UNITD=DESCRA(3:3) -C -C B = INV(A)*B OR B=INV(A')*B -C - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': entry',m,n - - IF (psb_toupper(TDIAG).EQ.'R') THEN - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': Right Scale' - DO I = 1, N - DO K = 1, M - B(K,I) = B(K,I)*VDIAG(K) - ENDDO - ENDDO - END IF - - PNG = IA(1) - PIA = IA(2) - PJA = IA(3) - - DO I = 1, N - CALL SJADSV(UNITD,M,IA(PNG), - + AR,JA,IA(PIA),IA(PJA),B(1,I),C(1,I),IERROR) - ENDDO - IF(IERROR.NE.0) THEN - INT_VAL(1)=IERROR - CALL FCPSB_ERRPUSH(4012,NAME,INT_VAL) - GOTO 9999 - END IF - - - IF (psb_toupper(TDIAG).EQ.'L') THEN - if (debug_level >= psb_debug_serial_comp_) - + write(debug_unit,*) trim(name),': Left Scale' - DO I = 1, N - DO K = 1, M - C(K,I) = C(K,I)*VDIAG(K) - ENDDO - ENDDO - END IF - - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - RETURN - - 9999 CONTINUE - CALL FCPSB_ERRACTIONRESTORE(ERR_ACT) - - IF ( ERR_ACT .NE. 0 ) THEN - CALL FCPSB_SERROR() - RETURN - ENDIF - - RETURN - END diff --git a/base/serial/jad/sjadsv.f b/base/serial/jad/sjadsv.f deleted file mode 100644 index b3ff3a057..000000000 --- a/base/serial/jad/sjadsv.f +++ /dev/null @@ -1,88 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C This routine compute only the casew with Unit diagonal ... - SUBROUTINE SJADSV(UNITD,NROW,NG,A,KA,IA,JA,X,Y,IERROR) - use psb_const_mod - implicit none - real(psb_spk_) A(*),X(*),Y(*) - integer IA(3,*),JA(*),KA(*),nrow,ng,i,j,k,ipg,ip2,ipx - CHARACTER UNITD - INTEGER IERROR - - IERROR=0 - - IF (UNITD.EQ.'U') THEN - - IF (NG.EQ.0) THEN - DO I = 1, NROW - Y(I) = X(I) - ENDDO - ENDIF - - DO IPG=1,NG - DO I = IA(1,IPG),IA(1,IPG+1)-1 - Y(I) = X(I) - END DO -* -* LOOP ON COLUMNS -* --------------- -* - IP2 = IA(2,IPG) - DO K = IP2, IA(3,IPG)-1 - IPX = IA(1,IPG) - DO I = JA(K), JA(K+1)-1 - Y(IPX) = Y(IPX) - A(I)*Y(KA(I)) - IPX = IPX+1 - ENDDO - ENDDO -* -* -* LOOP ON ROWS -* --------------- -* - IPX = IA(1,IPG) - DO K = IA(3,IPG), IA(2,IPG+1)-1 - DO I = JA(K), JA(K+1)-1 - Y(IPX) = Y(IPX) - A(I)*Y(KA(I)) - ENDDO - IPX = IPX + 1 - ENDDO - -**************************************** - END DO !END LOOP ON IPG=1,NG -**************************************** - ELSE - WRITE(0,*) 'ERROR in DJADSV' - ENDIF - RETURN - END - diff --git a/base/serial/jad/sjdnrmi.f b/base/serial/jad/sjdnrmi.f deleted file mode 100644 index 8d1dceb18..000000000 --- a/base/serial/jad/sjdnrmi.f +++ /dev/null @@ -1,61 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute infinity norm for sparse matrix in CSR Format ... - FUNCTION SJDNRMI(TRANS,M,N,DESCRA,A,JA,IA, - + INFOA,IERROR) - use psb_const_mod - IMPLICIT NONE - real(psb_spk_) sjdnrmi -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER JA(*),IA(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_spk_) A(*) -C .. Local scalars .. - INTEGER PNG, PIA, PJA -C .. External routines .. - real(psb_spk_) SJADNR - EXTERNAL SJADNR - - IERROR=0 - PNG = IA(1) - PIA = IA(2) - PJA = IA(3) - sjdnrmi = 0.0 - IF (DESCRA(1:1).EQ.'G') THEN - SJDNRMI = SJADNR(TRANS,M,N,IA(PNG), - + A,JA,IA(PJA),IA(PIA), - + INFOA,IERROR) - ENDIF - END diff --git a/base/serial/jad/sjdrws.f b/base/serial/jad/sjdrws.f deleted file mode 100644 index 1d5ad16a8..000000000 --- a/base/serial/jad/sjdrws.f +++ /dev/null @@ -1,60 +0,0 @@ -C -C Parallel Sparse BLAS version 2.2 -C (C) Copyright 2006/2007/2008 -C Salvatore Filippone University of Rome Tor Vergata -C Alfredo Buttari University of Rome Tor Vergata -C -C Redistribution and use in source and binary forms, with or without -C modification, are permitted provided that the following conditions -C are met: -C 1. Redistributions of source code must retain the above copyright -C notice, this list of conditions and the following disclaimer. -C 2. Redistributions in binary form must reproduce the above copyright -C notice, this list of conditions, and the following disclaimer in the -C documentation and/or other materials provided with the distribution. -C 3. The name of the PSBLAS group or the names of its contributors may -C not be used to endorse or promote products derived from this -C software without specific written permission. -C -C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -C ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -C TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -C PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -C BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -C CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -C SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -C INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -C CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -C ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -C POSSIBILITY OF SUCH DAMAGE. -C -C -C ... Compute infinity norm for sparse matrix in CSR Format ... - SUBROUTINE SJDRWS(TRANS,M,N,DESCRA,A,JA,IA, - + INFOA,ROWSUM,IERROR) - use psb_const_mod - IMPLICIT NONE -C .. Scalar Arguments .. - INTEGER M,N, IERROR - CHARACTER TRANS -C .. Array Arguments .. - INTEGER JA(*),IA(*),INFOA(*) - CHARACTER DESCRA*11 - real(psb_spk_) A(*), ROWSUM(*) -C .. Local scalars .. - INTEGER PNG, PIA, PJA -C .. External routines .. - - IERROR = 0 - PNG = IA(1) - PIA = IA(2) - PJA = IA(3) - - IF (DESCRA(1:1).EQ.'G') THEN - CALL SJADRWS(TRANS,M,N,IA(PNG), - + A,JA,IA(PJA),IA(PIA), - + INFOA,ROWSUM,IERROR) - ELSE - IERROR = 3011 - ENDIF - END diff --git a/base/serial/psb_ccoins.f90 b/base/serial/psb_ccoins.f90 deleted file mode 100644 index 78914e738..000000000 --- a/base/serial/psb_ccoins.f90 +++ /dev/null @@ -1,620 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ccoins.f90 -! Subroutine: psb_ccoins -! Takes a cloud of coefficients and inserts them into a sparse matrix. -! This subroutine is the serial, inner counterpart to the outer, user-level -! psb_spins. -! -! Arguments: -! -! nz - integer, input The number of points to insert. -! ia(:) - integer, input The row indices of the coefficients. -! ja(:) - integer, input The column indices of the coefficients. -! val(:) - complex, input The values of the coefficients to be inserted. -! a - type(psb_cspmat_type), inout The sparse destination matrix. -! imin - integer, input The minimum valid row index -! imax - integer, input The maximum valid row index -! jmin - integer, input The minimum valid col index -! jmax - integer, input The maximum valid col index -! info - integer, output Return code. -! gtl(:) - integer, input,optional An index mapping to be applied -! default: identity -! rebuild - logical, input, optional Rebuild in case of update -! finding a new index. Default: false. -! Not fully tested. -! -subroutine psb_ccoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_error_mod - use psb_serial_mod, psb_protect_name => psb_ccoins - use psb_update_mod - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax - integer, intent(in) :: ia(:),ja(:) - complex(psb_spk_), intent(in) :: val(:) - type(psb_cspmat_type), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - logical, intent(in), optional :: rebuild - - character(len=5) :: ufida - integer :: ng, nza, isza,spstate, & - & ip1, nzl, err_act, int_err(5), iupd, irst - integer :: debug_level, debug_unit - logical :: rebuild_ - character(len=20) :: name, ch_err - type(psb_cspmat_type) :: tmp - - name='psb_ccoins' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - info = 0 - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (present(rebuild)) then - rebuild_ = rebuild - else - rebuild_ = .false. - end if - - ufida = psb_toupper(a%fida) - spstate = psb_sp_getifld(psb_state_,a,info) - - - if (present(gtl)) then - - ng = size(gtl) - select case(spstate) - case(psb_spmat_bld_) - if ((ufida /= 'COO').and.(ufida/='COI')) then - info = 134 - ch_err(1:3)=ufida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info,gtl,ng) - - if(info /= izero) then - - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%infoa(psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': insert discarded items ' - end if - end if - if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - endif - call psb_sp_setifld(nza,psb_nnz_,a,info) - - case(psb_spmat_upd_) - - iupd = psb_sp_getifld(psb_upd_,a,info) - select case (iupd) - case (psb_upd_perm_) - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - nzl = psb_sp_getifld(psb_del_bnd_,a,info) - select case(ufida) - case ('JAD') - nza = a%ia1(ip1+psb_nnz_) - case default - nza = a%ia2(ip1+psb_nnz_) - end select - - call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - if (info /= izero) then - ch_err='psb_inner_upd' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': update discarded items ' - end if - end if - - select case(ufida) - case ('JAD') - a%ia1(ip1+psb_nnz_) = nza - case default - a%ia2(ip1+psb_nnz_) = nza - end select - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': (UPD) : NZA:',nza - - case (psb_upd_srch_) - - call psb_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - if (info > 0) then - if (rebuild_) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*)& - & trim(name),& - & ': Going through rebuild_ fingers crossed!' - irst = info - call psb_nullify_sp(tmp) - call psb_spcnv(a,tmp,info,afmt='coo') - if(info /= izero) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst - call psb_move_alloc(tmp,a,info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_transfer' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) write(debug_unit,*)& - & trim(name),': Reinserting',a%fida,nza,isza,irst,nz - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - if (irst <= nz) then - call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& - & nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - &imin,imax,jmin,jmax,info,gtl,ng) - if (info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - endif - - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - call psb_sp_setifld(nza,psb_nnz_,a,info) - end if - - else - info = 2231 - call psb_errpush(info,name) - goto 9999 - end if - else if (info < 0) then - info = 2230 - call psb_errpush(info,name) - goto 9999 - - end if - - case default - - info = 2231 - call psb_errpush(info,name) - goto 9999 - end select - - - case default - info = 2232 - call psb_errpush(info,name) - goto 9999 - end select - - - - - - else - - ng = -1 - - select case(spstate) - case(psb_spmat_bld_) - if ((ufida /= 'COO').and.(ufida/='COI')) then - info = 134 - ch_err(1:3)=ufida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info) - - if(info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%infoa(psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': insert discarded items ' - end if - end if - if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - endif - call psb_sp_setifld(nza,psb_nnz_,a,info) - - case(psb_spmat_upd_) - - iupd = psb_sp_getifld(psb_upd_,a,info) - select case (iupd) - case (psb_upd_perm_) - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - nzl = psb_sp_getifld(psb_del_bnd_,a,info) - nza = a%ia2(ip1+psb_nnz_) - - - call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& - & imin,imax,jmin,jmax,nzl,info) - if (info /= izero) then - ch_err='psb_inner_upd' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) then - if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': update discarded items ' - end if - end if - a%ia2(ip1+psb_nnz_) = nza - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),':(UPD) : NZA:',nza - - case (psb_upd_srch_) - - call psb_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) - - if (info > 0) then - if (rebuild_) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*)& - & trim(name),& - & ': Going through rebuild_ fingers crossed!' - irst = info - call psb_nullify_sp(tmp) - call psb_spcnv(a,tmp,info,afmt='coo') - call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst - call psb_move_alloc(tmp,a,info) - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) write(debug_unit,*)& - & trim(name),': Reinserting',a%fida,nza,isza - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - if (irst <= nz) then - call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& - & nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info) - if (info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - endif - - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - call psb_sp_setifld(nza,psb_nnz_,a,info) - end if - - else - info = 2231 - call psb_errpush(info,name) - goto 9999 - end if - else if (info < 0) then - info = 2230 - call psb_errpush(info,name) - goto 9999 - - end if - - case default - - info = 2233 - call psb_errpush(info,name) - goto 9999 - end select - - - case default - info = 2232 - call psb_errpush(info,name) - goto 9999 - end select - endif - - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -contains - - subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,maxsz,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,maxsz - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_spk_), intent(in) :: val(:) - complex(psb_spk_), intent(inout) :: aspk(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic - character(len=20) :: name, ch_err - - - name='psb_inner_upd' - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - if ((nza > nzl)) then - do i=1, nz - nza = nza + 1 - if (nza>maxsz) then - call psb_errpush(50,name,i_err=(/7,maxsz,5,0,nza /)) - info = -71 - return - endif - aspk(nza) = val(i) - end do - else - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza>maxsz) then - info = -72 - return - endif - aspk(nza) = val(i) - end if - end if - end do - end if - else - if ((nza >= nzl)) then - do i=1, nz - nza = nza + 1 - if (nza>maxsz) then - info = -73 - return - endif - aspk(nza) = val(i) - end do - else - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza>maxsz) then - info = -74 - return - endif - aspk(nza) = val(i) - end if - end do - end if - end if - end subroutine psb_inner_upd - - subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& - & imin,imax,jmin,jmax,info,gtl,ng) - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza,ia1(:),ia2(:) - complex(psb_spk_), intent(in) :: val(:) - complex(psb_spk_), intent(inout) :: aspk(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic - - info = 0 - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza > maxsz) then - info = -91 - return - endif - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end if - end do - else - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza > maxsz) then - info = -92 - return - endif - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end do - end if - - end subroutine psb_inner_ins - -end subroutine psb_ccoins - diff --git a/base/serial/psb_ccsmm.f90 b/base/serial/psb_ccsmm.f90 deleted file mode 100644 index 049af14bc..000000000 --- a/base/serial/psb_ccsmm.f90 +++ /dev/null @@ -1,89 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ccsmm.f90 -! Subroutine: -! Arguments: -subroutine psb_ccsmm(alpha,a,b,beta,c,info,trans) - use psb_spmat_type, psb_protect_name => psb_ccsmm - use psb_error_mod - implicit none - - class(psb_cspmat_type) :: a - complex(psb_spk_) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans - - complex(psb_spk_), allocatable :: work(:) - character :: trans_ - integer :: iwsz,m,n,k,lb,lc,err_act - character(len=20) :: name - - name='psb_ccsmm' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if ((trans_=='N').or.(trans_=='n')) then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - n = min(size(b,2),size(c,2)) - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call ccsmm(trans_,m,n,k,alpha,& - & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_ccsmm diff --git a/base/serial/psb_ccsmv.f90 b/base/serial/psb_ccsmv.f90 deleted file mode 100644 index ec72f4c6f..000000000 --- a/base/serial/psb_ccsmv.f90 +++ /dev/null @@ -1,90 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ccsmv.f90 -! Subroutine: -! Arguments: - -subroutine psb_ccsmv(alpha,a,b,beta,c,info,trans) - use psb_spmat_type, psb_protect_name => psb_ccsmv - use psb_error_mod - implicit none - - class(psb_cspmat_type) :: a - complex(psb_spk_) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans - - complex(psb_spk_), allocatable :: work(:) - character :: trans_ - integer :: iwsz,m,n,k,lb,lc, err_act - character(len=20) :: name - - name='psb_ccsmv' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if ((trans_=='N').or.(trans_=='n')) then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - n = 1 - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call ccsmm(trans_,m,n,k,alpha,& - & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_ccsmv diff --git a/base/serial/psb_ccsnmi.f90 b/base/serial/psb_ccsnmi.f90 deleted file mode 100644 index f803e0f60..000000000 --- a/base/serial/psb_ccsnmi.f90 +++ /dev/null @@ -1,93 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ccsnmi.f90 -! Subroutine: -! Arguments: - -function psb_ccsnmi(a,info,trans) - - use psb_spmat_type - use psb_error_mod - implicit none - - type(psb_cspmat_type), intent(in) :: a - integer, intent(out) :: info - character, optional :: trans - real(psb_spk_) :: psb_ccsnmi - interface - function ccsnmi(trans,m,n,fida,descra,a,ia1,ia2,& - & infoa,ierror) - use psb_const_mod - real(psb_spk_) :: ccsnmi - integer :: m,n, ierror - character :: trans - integer :: ia1(*),ia2(*),infoa(*) - character :: descra*11, fida*5 - complex(psb_spk_) :: a(*) - end function ccsnmi - end interface - - integer :: err_act - character :: itrans - character(len=20) :: name, ch_err - - name='psb_ccsnmi' - call psb_erractionsave(err_act) - - if(present(trans)) then - itrans=trans - else - itrans='N' - end if - - psb_ccsnmi = ccsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info) - if(info/=0) then - psb_ccsnmi = -1 - info=4010 - ch_err='psb_ccsnmi' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end function psb_ccsnmi diff --git a/base/serial/psb_ccsprt.f90 b/base/serial/psb_ccsprt.f90 deleted file mode 100644 index 39d9d9c05..000000000 --- a/base/serial/psb_ccsprt.f90 +++ /dev/null @@ -1,199 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ccsprt.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* Print out a matrix. * -!* Should really align with the F77 version under the SERIAL dir, which * -!* does a nice printout in MatrixMarket format; this would be a quick job. * -!* * -!* Handles both a shift in the row/col indices and a fuctional transform * -!* on the indices. * -!* * -!* * -!* * -!* * -!***************************************************************************** -subroutine psb_ccsprt(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_spmat_type - use psb_string_mod - implicit none - - integer, intent(in) :: iout - type(psb_cspmat_type), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% ',psb_toupper(a%fida) - endif - - nmx = max(a%m,a%k,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es16.8,1x),2(i',ni,',1x))' - - - select case(psb_toupper(a%fida)) - - case ('CSR') - - write(iout,*) a%m,a%k,a%ia2(a%m+1)-1 - - if (present(iv)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) iv(irs+i),iv(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+i),(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+i),ivc(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+i),ivc(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+i),(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - endif - endif - - case ('CSC') - - write(iout,*) a%m,a%k,a%ia2(a%k+1)-1 - - if (present(iv)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) iv(irs+a%ia1(j)),iv(ics+i),a%aspk(j) - enddo - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+a%ia1(j)),(ics+i),a%aspk(j) - enddo - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+a%ia1(j)),ivc(ics+i),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+a%ia1(j)),ivc(ics+i),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+a%ia1(j)),(ics+i),a%aspk(j) - enddo - enddo - endif - endif - - case ('COO') - if(present(iv)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) iv(a%ia1(j)),iv(a%ia2(j)),a%aspk(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) ivr(a%ia1(j)),a%ia2(j),a%aspk(j) - enddo - else if (present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) ivr(a%ia1(j)),ivc(a%ia2(j)),a%aspk(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) a%ia1(j),ivc(a%ia2(j)),a%aspk(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) a%ia1(j),a%ia2(j),a%aspk(j) - enddo - endif - endif - case default - write(0,*) 'Feeling lazy today, format not implemented: "',a%fida,'"' - end select - -end subroutine psb_ccsprt diff --git a/base/serial/psb_ccssm.f90 b/base/serial/psb_ccssm.f90 deleted file mode 100644 index 177edc11e..000000000 --- a/base/serial/psb_ccssm.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcssm.f90 -! Subroutine: -! Arguments: - -subroutine psb_ccssm(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type, psb_protect_name => psb_ccssm - use psb_error_mod - implicit none - - class(psb_cspmat_type) :: t - complex(psb_spk_) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans, unitd - complex(psb_spk_), optional, target :: d(:) - - complex(psb_spk_), allocatable :: work(:) - complex(psb_spk_), pointer :: ddl(:) - character :: lt, lu - integer :: iwsz,m,n,lb,lc,err_act - character(len=20) :: name - - name='psb_ccssm' - info = 0 - call psb_erractionsave(err_act) - - - if (present(trans)) then - lt = trans - else - lt = 'N' - endif - if (present(unitd)) then - lu = unitd - else - lu = 'U' - endif - if (present(d)) then - ddl => d - else - allocate(ddl(1)) - endif - - m = t%m - n = min(size(b,2),size(c,2)) - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call ccssm(lt,m,n,alpha,lu,ddl,& - & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - if (.not.present(d)) then - deallocate(ddl) - endif - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_ccssm diff --git a/base/serial/psb_ccssv.f90 b/base/serial/psb_ccssv.f90 deleted file mode 100644 index 03ba9ffc9..000000000 --- a/base/serial/psb_ccssv.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ccssv.f90 -! Subroutine: -! Arguments: - -subroutine psb_ccssv(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type, psb_protect_name => psb_ccssv - use psb_error_mod - implicit none - - class(psb_cspmat_type) :: t - complex(psb_spk_) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans, unitd - complex(psb_spk_), optional, target :: d(:) - - complex(psb_spk_), allocatable :: work(:) - complex(psb_spk_), pointer :: ddl(:) - character :: lt, lu - integer :: iwsz,m,n,lb,lc,err_act - character(len=20) :: name - - name='psb_ccssv' - info = 0 - call psb_erractionsave(err_act) - - - if (present(trans)) then - lt = trans - else - lt = 'N' - endif - if (present(unitd)) then - lu = unitd - else - lu = 'U' - endif - if (present(d)) then - ddl => d - else - allocate(ddl(1)) - endif - - m = t%m - n = 1 - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call ccssm(lt,m,n,alpha,lu,ddl,& - & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - if (.not.present(d)) then - deallocate(ddl) - endif - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_ccssv diff --git a/base/serial/psb_cest.f90 b/base/serial/psb_cest.f90 deleted file mode 100644 index b76fbf200..000000000 --- a/base/serial/psb_cest.f90 +++ /dev/null @@ -1,120 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_cest(afmt,m,n,nnz, lia1, lia2, lar, iup,info) - - use psb_error_mod - use psb_const_mod - use psb_string_mod - use psb_serial_mod - - implicit none - - ! .. scalar arguments .. - integer, intent(in) :: m,n,nnz,iup - integer, intent(out) :: lia1, lia2, lar, info - character(len=*), intent(inout) :: afmt - ! .. array arguments.. - integer :: int_val(5), err_act - character(len=20) :: name - - name = 'psb_cest' - call psb_erractionsave(err_act) - - if (afmt == '???') then - afmt = psb_fidef_ - endif - - afmt = psb_toupper(afmt) - - select case(iup) - case (psb_upd_perm_) - if (afmt == 'JAD') then - lia1 = 2*(nnz) + 1000 - lia2 = (3*nnz)/2 + 1000 + m - lar = (3*nnz)/2 - else if (afmt == 'COO') then - lia1 = nnz - lia2 = 2*nnz + 1000 - lar = nnz - else if(afmt == 'CSR') then - lia1 = nnz - lia2 = 2*nnz + 1000 + m + 1 - lar = nnz - else - info = 136 - call psb_errpush(info,name,a_err=psb_toupper(afmt)) - goto 9999 - endif - - case (psb_upd_srch_) - - if (afmt == 'JAD') then - lia1 = (3*nnz)/2 - lia2 = (3*nnz)/2 - lar = (3*nnz)/2 - else if (afmt == 'COO') then - lia1 = nnz - lia2 = nnz - lar = nnz - else if(afmt == 'CSR') then - lia1 = nnz - lia2 = max(nnz,m+1) - lar = nnz - else - info = 136 - call psb_errpush(info,name,a_err=psb_toupper(afmt)) - goto 9999 - endif - - case default - - info = 3012 - call psb_errpush(info,name,int_val) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if ( err_act /= 0 ) then - call psb_error() - return - endif - - return - -end subroutine psb_cest - diff --git a/base/serial/psb_cfixcoo.f90 b/base/serial/psb_cfixcoo.f90 deleted file mode 100644 index 5ecfa3830..000000000 --- a/base/serial/psb_cfixcoo.f90 +++ /dev/null @@ -1,269 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cfixcoo.f90 -! Subroutine: -! Arguments: - -Subroutine psb_cfixcoo(a,info,idir) - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_cfixcoo - use psb_ip_reord_mod - use psb_error_mod - implicit none - - !....Parameters... - Type(psb_cspmat_type), intent(inout) :: A - Integer, intent(out) :: info - integer, intent(in), optional :: idir - - integer, allocatable :: iaux(:) - !locals - Integer :: nza, nzl,iret,idir_, dupl_ - integer :: i,j, irw, icl, err_act - integer :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(a%ia1),size(a%ia2) - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) 'Fixcoo Invalid input ',a%fida - info = -1 - return - end if - if (present(idir)) then - idir_ = idir - else - idir_ = 0 - endif - - nza = psb_sp_getifld(psb_nnz_,a,info) - if (nza < 2) return - - dupl_ = psb_sp_getifld(psb_dupl_,a,info) - - allocate(iaux(nza+2),stat=info) - if (info /= 0) return - - select case(idir_) - - case(0) ! Row major order - - call msort_up(nza,a%ia1(1),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nza,a%aspk,a%ia1,a%ia2,iaux) - i = 1 - j = i - do while (i <= nza) - do while ((a%ia1(j) == a%ia1(i))) - j = j+1 - if (j > nza) exit - enddo - nzl = j - i - call msort_up(nzl,a%ia2(i),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,a%aspk(i:i+nzl-1),& - & a%ia1(i:i+nzl-1),a%ia2(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = a%ia1(i) - icl = a%ia2(i) - j = 1 - - select case(dupl_) - case(psb_dupl_ovwrt_) - - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_add_) - - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - call psb_errpush(130,name) - goto 9999 - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - end select - - - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - case(1) ! Col major order - - call msort_up(nza,a%ia2(1),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nza,a%aspk,a%ia1,a%ia2,iaux) - i = 1 - j = i - do while (i <= nza) - do while ((a%ia2(j) == a%ia2(i))) - j = j+1 - if (j > nza) exit - enddo - nzl = j - i - call msort_up(nzl,a%ia1(i),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,a%aspk(i:i+nzl-1),& - & a%ia1(i:i+nzl-1),a%ia2(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = a%ia1(i) - icl = a%ia2(i) - j = 1 - - - select case(dupl_) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - call psb_errpush(130,name) - goto 9999 - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - end select - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - case default - write(debug_unit,*) trim(name),': unknown direction ',idir_ - end select - - call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info) - call psb_sp_setifld(i,psb_nnz_,a,info) - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info) - - deallocate(iaux) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_cfixcoo diff --git a/base/serial/psb_cgelp.f90 b/base/serial/psb_cgelp.f90 deleted file mode 100644 index ac38586b7..000000000 --- a/base/serial/psb_cgelp.f90 +++ /dev/null @@ -1,251 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cgelp.f90 -! -! -! Subroutine: psb_cgelp -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:,:). -! info - integer. Return code. -subroutine psb_cgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_cgelp - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_spk_), intent(inout) :: x(:,:) - integer, intent(in) :: iperm(:) - integer, intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer :: ictxt - complex(psb_spk_),allocatable :: dtemp(:) - integer, allocatable :: itemp(:) - integer :: int_err(5), i1sz, i2sz, err_act - real(psb_spk_),parameter :: one=1 - logical, parameter :: debug=.false. - - interface - subroutine cgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(psb_spk_), intent(inout) :: b(ldb,*), work(*) - integer, intent(in) :: p(*) - end subroutine cgelp - end interface - - character(len=20) :: name, ch_err - name = 'psb_cgelp' - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug) write(*,*) 'gelp: ',i1sz,i2sz - allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - - call cgelp(trans,i1sz,i2sz,itemp,x,i1sz,dtemp,i1sz,info) - if(info /= 0) then - info=4010 - ch_err='zgelp' - call psb_errpush(info,name,a_err=ch_err) - end if - - deallocate(dtemp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_cgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! WARNING: This routine should be changed and moved to the serial part -! i.e. taking out the descriptor. -! -! -! Subroutine: psb_cgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_cgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_cgelpv - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_spk_), intent(inout) :: x(:) - integer, intent(in) :: iperm(:) - integer, intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer :: ictxt - integer :: int_err(5), i1sz, err_act - complex(psb_spk_),allocatable :: dtemp(:) - integer, allocatable :: itemp(:) - real(psb_spk_),parameter :: one=1 - logical, parameter :: debug=.false. - - interface cgelp - subroutine cgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(psb_spk_), intent(inout) :: b(*), work(*) - integer, intent(in) :: p(*) - end subroutine cgelp - end interface - - - character(len=20) :: name, ch_err - name = 'psb_cgelpv' - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - i1sz = size(x) - - - if (debug) write(*,*) 'gelp: ',i1sz - allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - - call cgelp(trans,i1sz,1,itemp,x,i1sz,dtemp,i1sz,info) - if(info /= 0) then - info=4010 - ch_err='zgelp' - call psb_errpush(info,name,a_err=ch_err) - end if - - deallocate(dtemp) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_cgelpv - diff --git a/base/serial/psb_cipcoo2csc.f90 b/base/serial/psb_cipcoo2csc.f90 deleted file mode 100644 index 619d4d47e..000000000 --- a/base/serial/psb_cipcoo2csc.f90 +++ /dev/null @@ -1,221 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cipcoo2csc.f90 -! Subroutine: -! Arguments: - -subroutine psb_cipcoo2csc(a,info,clshr) - use psb_spmat_type - use psb_const_mod - use psb_serial_mod, psb_protect_name => psb_cipcoo2csc - use psb_error_mod - use psb_string_mod - use psb_realloc_mod - implicit none - - !....Parameters... - Type(psb_cspmat_type), intent(inout) :: A - Integer, intent(out) :: info - logical, optional :: clshr - - integer, allocatable :: iaux(:), itemp(:) - !locals - logical :: clshr_ - Integer :: nza, i,j, idl,err_act,nc,icl - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name - - name='psb_ipcoo2csc' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) write(debug_unit,*) & - & trim(name),': start',a%fida,a%m - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) trim(name),' Invalid input ',a%fida - info = -1 - call psb_errpush(info,name) - goto 9999 - end if - if (present(clshr)) then - clshr_ = clshr - else - clshr_ = .false. - end if - - call psb_fixcoo(a,info,idir=1) - if (info == 0) then - nc = a%k - nza = a%infoa(psb_nnz_) - allocate(iaux(max(nc+1,1)),stat=info) - end if - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nc+1,1),0,0,0,0/)) - goto 9999 - end if - if(debug_level >= psb_debug_serial_) write(debug_unit,*) trim(name),& - & ': out of fixcoo',nza,nc,size(a%ia2),size(iaux) - - call psb_move_alloc(a%ia2,itemp,info) - if (info == 0) call psb_move_alloc(iaux,a%ia2,info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_move_alloc') - goto 9999 - end if - - ! - ! This routine can be used in two modes: - ! 1. Normal: just look at the col indices and trust them. This - ! implies putting in empty cols where needed. In this case you - ! can get in trouble if A%M < A%IA1(NZA) - ! 2. Shrink mode: disregard the actual value of the col indices, - ! just treat them as ident markers. In this case you can get in - ! trouble when the number of distinct col indices is greater - ! than A%M - ! - ! - - a%ia2(1) = 1 - - if (nza <= 0) then - do i=1,nc - a%ia2(i+1) = a%ia2(i) - end do - else - - if (clshr_) then - - j = 1 - i = 1 - icl = itemp(j) - - do j=1, nza - if (itemp(j) /= icl) then - a%ia2(i+1) = j - icl = itemp(j) - i = i + 1 - if (i>nc) then - write(debug_unit,*) trim(name),': CLSHR=.true. : ',& - & i, nc,' Expect trouble!' - exit - end if - endif - enddo -! write(debug_unit,*) 'Exit from loop',j,nza,i - do - if (i>=nc+1) exit - a%ia2(i+1) = j - i = i + 1 - end do - - else - - if (nc < itemp(nza)) then - write(debug_unit,*) trim(name),': CLSHR=.false. : ',& - &nc,itemp(nza),' Expect trouble!' - end if - - - j = 1 - i = 1 - icl = itemp(j) - - outer: do - inner: do - if (i >= icl) exit inner - if (i>nc) then - write(debug_unit,*) trim(name),& - & 'strange situation: i>nc ',i,nc,j,nza,icl,idl - exit outer - end if - a%ia2(i+1) = a%ia2(i) - i = i + 1 - end do inner - j = j + 1 - if (j > nza) exit - if (itemp(j) /= icl) then - if (i>nc) then - write(debug_unit,*) trim(name), & - &'Strange situation: ',i,nc,size(a%ia2),& - & nza,j,itemp(j) - end if - a%ia2(i+1) = j - icl = itemp(j) - i = i + 1 - endif - if (i>nc) exit - enddo outer - ! - ! Cleanup empty cols at the end - ! - if (j /= (nza+1)) then - write(debug_unit,*) trim(name),': Problem from loop :',j,nza,itemp(j) - endif - do - if (i>nc) exit - a%ia2(i+1) = j - i = i + 1 - end do - - endif - - end if - -!!$ write(debug_unit,*) 'IPcoo2csc end loop ',i,nc,a%ia2(nc+1),nza - a%fida='CSC' - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp,stat=info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='deallocate') - goto 9999 - end if - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_cipcoo2csc diff --git a/base/serial/psb_cipcoo2csr.f90 b/base/serial/psb_cipcoo2csr.f90 deleted file mode 100644 index 189ca7ccb..000000000 --- a/base/serial/psb_cipcoo2csr.f90 +++ /dev/null @@ -1,213 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cipcoo2csr.f90 -! Subroutine: -! Arguments: - -subroutine psb_cipcoo2csr(a,info,rwshr) - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_serial_mod, only : psb_fixcoo - use psb_error_mod - use psb_string_mod - implicit none - - !....Parameters... - Type(psb_cspmat_type), intent(inout) :: A - Integer, intent(out) :: info - logical, optional :: rwshr - - integer, allocatable :: iaux(:), itemp(:) - !locals - logical :: rwshr_ - Integer :: nza, nr, i,j,irw, idl,err_act - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name - - name='psb_ipcoo2csr' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': start',a%fida,a%m - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) trim(name),': Invalid input ',a%fida - info = -1 - call psb_errpush(info,name) - goto 9999 - end if - if (present(rwshr)) then - rwshr_ = rwshr - else - rwshr_ = .false. - end if - - call psb_fixcoo(a,info) - nr = a%m - nza = a%infoa(psb_nnz_) - allocate(iaux(max(nr+1,1)),stat=info) - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nr+1,1),0,0,0,0/)) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & ': out of fixcoo',nza,nr,size(a%ia2),size(iaux) - - call psb_move_alloc(a%ia1,itemp,info) - call psb_move_alloc(a%ia2,a%ia1,info) - call psb_move_alloc(iaux,a%ia2,info) - - ! - ! This routine can be used in two modes: - ! 1. Normal: just look at the row indices and trust them. This - ! implies putting in empty rows where needed. In this case you - ! can get in trouble if A%M < A%IA1(NZA) - ! 2. Shrink mode: disregard the actual value of the row indices, - ! just treat them as ident markers. In this case you can get in - ! trouble when the number of distinct row indices is greater - ! than A%M - ! - ! - - a%ia2(1) = 1 - - if (nza <= 0) then - do i=1,nr - a%ia2(i+1) = a%ia2(i) - end do - else - - if (rwshr_) then - - - j = 1 - i = 1 - irw = itemp(j) - - do j=1, nza - if (itemp(j) /= irw) then - a%ia2(i+1) = j - irw = itemp(j) - i = i + 1 - if (i>nr) then - write(debug_unit,*) trim(name),': RWSHR=.true. : ',& - & i, nr,' Expect trouble!' - exit - end if - endif - enddo - do - if (i>=nr+1) exit - a%ia2(i+1) = j - i = i + 1 - end do - - else - - if (nr < itemp(nza)) then - write(debug_unit,*) trim(name),': RWSHR=.false. : ',& - &nr,itemp(nza),' Expect trouble!' - info = 12 - end if - - - j = 1 - i = 1 - irw = itemp(j) - - outer: do - inner: do - if (i >= irw) exit inner - if (i>nr) then - write(debug_unit,*) trim(name),& - & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl - exit outer - end if - a%ia2(i+1) = a%ia2(i) - i = i + 1 - end do inner - j = j + 1 - if (j > nza) exit - if (itemp(j) /= irw) then - a%ia2(i+1) = j - irw = itemp(j) - i = i + 1 - endif - if (i>nr) exit - enddo outer - ! - ! Cleanup empty rows at the end - ! - if (j /= (nza+1)) then - write(debug_unit,*) trim(name),': Problem from loop :',j,nza - info = 13 - endif - do - if (i>nr) exit - a%ia2(i+1) = j - i = i + 1 - end do - - endif - - end if - - a%fida='CSR' - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp,stat=info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='deallocate') - goto 9999 - end if - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_cipcoo2csr diff --git a/base/serial/psb_cipcsr2coo.f90 b/base/serial/psb_cipcsr2coo.f90 deleted file mode 100644 index d7f97f543..000000000 --- a/base/serial/psb_cipcsr2coo.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cipcsr2coo.f90 -! Subroutine: -! Arguments: - -Subroutine psb_cipcsr2coo(a,info) - use psb_spmat_type - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_realloc_mod - use psb_serial_mod, psb_protect_name => psb_cipcsr2coo - implicit none - - !....Parameters... - Type(psb_cspmat_type), intent(inout) :: A - Integer, intent(out) :: info - - !locals - Integer :: nza, nr - integer :: i,j,err_act - integer, allocatable :: iaux(:), itemp(:) - character(len=20) :: name='psb_cipcsr2coo' - - info = 0 - call psb_erractionsave(err_act) - - if (psb_toupper(a%fida) /= 'CSR') then - info = 5 - call psb_errpush(info,name) - goto 9999 - end if - - nr = a%m - nza = a%ia2(nr+1) - 1 - allocate(iaux(max(nza,1)),stat=info) - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nza,1),0,0,0,0/)) - goto 9999 - end if -!!$ write(0,*) 'ipcsr2coo ',a%m - call psb_move_alloc(a%ia2,itemp,info) - call psb_move_alloc(a%ia1,a%ia2,info) - call psb_move_alloc(iaux,a%ia1,info) - - do i=1, nr - do j=itemp(i),itemp(i+1)-1 - a%ia1(j) = i - end do - end do - - a%fida='COO' - a%infoa(psb_nnz_) = nza - a%infoa(psb_srtd_) = psb_isrtdcoo_ - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp) - call psb_fixcoo(a,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_cipcsr2coo diff --git a/base/serial/psb_cneigh.f90 b/base/serial/psb_cneigh.f90 deleted file mode 100644 index 105dcbea7..000000000 --- a/base/serial/psb_cneigh.f90 +++ /dev/null @@ -1,121 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cneigh.f90 -! Subroutine: -! Arguments: - -subroutine psb_cneigh(a,idx,neigh,n,info,lev) - - use psb_realloc_mod - use psb_const_mod - use psb_spmat_type - use psb_serial_mod, psb_protect_name => psb_cneigh - implicit none - - - type(psb_cspmat_type), intent(in) :: a ! the sparse matrix - integer, intent(in) :: idx ! the index whose neighbours we want to find - integer, intent(out) :: n, info ! the number of neighbours and the info - integer, allocatable :: neigh(:) ! the neighbours - integer, optional, intent(in) :: lev ! level of neighbours to find - - integer :: lev_, i, nl, ifl,ill,& - & n1, err_act, nn, nidx,ntl - character(len=20) :: name - integer, allocatable :: ia(:), ja(:) - complex(psb_spk_), allocatable :: val(:) - - name='psb_cneigh' - info = 0 - call psb_erractionsave(err_act) - - n = 0 - info = 0 - if(present(lev)) then - lev_ = lev - else - lev_=1 - end if - - call psb_sp_getrow(idx,a,n,ia,ja,val,info) - if (info == 0) call psb_realloc(n,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(1:n) = ja(1:n) - ifl = 1 - ill = n - - - do nl = 2, lev_ - n1 = ill - ifl + 1 - call psb_ensure_size(ill+n1*n1,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - ntl = 0 - do i=ifl,ill - nidx=neigh(i) - if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then - call psb_sp_getrow(nidx,a,nn,ia,ja,val,info) - if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) - ntl = ntl+nn - end if - end do - call psb_msort_unique(neigh(ill+1:ill+ntl),nn) - ifl = ill + 1 - ill = ill + nn - end do - call imsru(ill,neigh,psb_sort_up_,nn) - n = nn - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_cneigh - diff --git a/base/serial/psb_cspclip.f90 b/base/serial/psb_cspclip.f90 deleted file mode 100644 index 9f56fd206..000000000 --- a/base/serial/psb_cspclip.f90 +++ /dev/null @@ -1,157 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cspclip.f90 -! Subroutine: psb_cspclip -! Creates a "clipped" copy of input matrix A. Output is always in COO. -! Arguments: - -!***************************************************************************** -!* * -!***************************************************************************** -subroutine psb_cspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_cspclip - implicit none - type(psb_cspmat_type), intent(in) :: a - type(psb_cspmat_type), intent(out) :: b - integer, intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - integer :: err_act - character(len=20) :: name - integer :: imin_,imax_,jmin_,jmax_ - logical :: rscale_,cscale_ - integer :: sizeb, nzb, mb, kb, ifst, ilst, nrt, nzt, i, j - integer, parameter :: irbk=40 - - name='psb_csp_clip' - info = 0 - call psb_erractionsave(err_act) - call psb_set_erraction(0) - - call psb_nullify_sp(b) - - - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - endif - if (present(imax)) then - imax_ = imax - else - imax_ = a%m - endif - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%k - endif - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - endif - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - endif - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%m ! Should this be imax_ ?? - endif - if (cscale_) then - kb = jmax_ - jmin_ +1 - else - kb = a%k ! Should this be jmax_ ?? - endif - - - sizeb = psb_sp_get_nnzeros(a) - call psb_sp_all(mb,kb,b,sizeb,info) - b%fida = 'COO' - b%descra = a%descra - nzb = 0 - do i=imin_, imax_, irbk - nrt = min(irbk,imax_-i+1) - ifst = i - ilst = ifst + nrt - 1 - call psb_sp_getrow(ifst,a,nzt,b%ia1,b%ia2,b%aspk,info,& - & lrw=ilst, append=.true.,nzin=nzb) - do j=nzb+1,nzb+nzt - if ((jmin_ <= b%ia2(j)).and.(b%ia2(j) <= jmax_)) then - nzb = nzb + 1 - b%aspk(nzb) = b%aspk(j) - b%ia1(nzb) = b%ia1(j) - b%ia2(nzb) = b%ia2(j) - end if - end do - - end do - b%infoa(psb_nnz_) = nzb - - if (rscale_) then - do i=1, nzb - b%ia1(i) = b%ia1(i) - imin_ + 1 - end do - end if - if (cscale_) then - do i=1, nzb - b%ia2(i) = b%ia2(i) - jmin_ + 1 - end do - end if - call psb_fixcoo(b,info) - call psb_sp_trim(b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_cspclip - diff --git a/base/serial/psb_cspcnv.f90 b/base/serial/psb_cspcnv.f90 deleted file mode 100644 index 7ff240f92..000000000 --- a/base/serial/psb_cspcnv.f90 +++ /dev/null @@ -1,573 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cspcnv.f90 -! -! Subroutine: psb_cspcnv2 -! This subroutine converts the storage format of a matrix. -! -! Arguments: -! -! a - type(psb_spmat_type), input The input matrix to be converted. -! b - type(psb_spmat_type), output The assembled output matrix. -! info - integer. Return code -! afmt - character, optional The desired storage format -! -subroutine psb_cspcnv2(a, b,info,afmt,upd,dupl) - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_cspcnv2 - implicit none - !....Parameters... - Type(psb_cspmat_type), intent(in) :: A - Type(psb_cspmat_type), intent(out) :: B - Integer, intent(out) :: info - Integer, intent(in), optional :: upd,dupl - character(len=*), optional, intent(in) :: afmt - - !...Locals... - complex(psb_dpk_) :: d(1) - complex(psb_dpk_), allocatable :: work(:) - type(psb_cspmat_type) :: temp_a - Integer :: nzr, ntry, ifc_, ia1_size,& - & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ - integer :: err_act - character :: check_,trans_,unitd_ - character(len=5) :: afmt_ - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - - name='psb_spcnv2' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ntry=0 - - ifc_ = 2 - - - check_ = 'N' - trans_ = 'N' - unitd_ = 'U' - allocate(work(max(size(a%ia1),size(a%ia2))+a%m+1000),stat=info) - - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,b,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,b,info) - end if - if (present(afmt)) then - afmt_ = psb_toupper(afmt) - else - afmt_ = psb_fidef_ - end if - - upd_ = psb_sp_getifld(psb_upd_,b,info) - select case(upd_) - case(psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,b,info) - end select - - dupl_ = psb_sp_getifld(psb_dupl_,b,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,b,info) - end select - - ! ...matrix conversion... - b%m=a%m - b%k=a%k - b%fida=psb_toupper(afmt_) - size_req = psb_sp_get_nnzeros(a) - ! - n_row=b%m - n_col=b%k - call psb_cest(afmt_,n_row,n_col,size_req,& - & ia1_size, ia2_size, aspk_size, upd_,info) - b%fida=afmt_ - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_cest' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - if (.not.allocated(b%aspk).or.& - &.not.allocated(b%ia1).or.& - &.not.allocated(b%ia2).or.& - &.not.allocated(b%pl).or.& - &.not.allocated(b%pr)) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - else if ((size(b%aspk) < aspk_size) .or.& - &(size(b%ia1) < ia1_size) .or.& - &(size(b%ia2) < ia2_size) .or.& - &(size(b%pl) < b%m) .or.& - &(size(b%pr) < b%k )) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - endif - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - b%pl(:) = 0 - b%pr(:) = 0 - - b%descra = a%descra - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': size_req 1:',& - & size_req, trans_,upd_,dupl_,b%fida,b%descra - - select case (psb_toupper(a%fida)) - - case ('CSR') - - select case (psb_toupper(b%fida)) - - case ('CSR') - - call ccrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - - if (info/=0) then - info=4010 - ch_err='dcrcr' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case ('JAD') - - !...converting to JAD - !...output matrix may not be big enough - do - - call ccrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - endif - - ntry = ntry + 1 - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),' On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(debug_unit,*) trim(name),& - & ' Tried reallocating for DCRJAD for ',maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - call psb_cest(afmt_,n_row,n_col,nzr,& - & ia1_size, ia2_size, aspk_size, upd_,info) - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - if (info/=0) then - call psb_errpush(info,name) - goto 9999 - end if - - case ('COO') - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),' Calling CRCO ',a%descra - call ccrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrco') - goto 9999 - end if - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - case ('COO','COI') - - select case (psb_toupper(b%fida)) - - case ('CSR') - - call ccocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - case ('JAD') - - call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - temp_a%m = a%m - temp_a%k = a%k - temp_a%infoa=b%infoa - !...Dirty trick: converting to CSR and then to JAD - - call ccocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, & - & size(temp_a%aspk), size(temp_a%ia1),& - & size(temp_a%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - do - call ccrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, & - & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, & - & size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - end if - - ntry = ntry + 1 - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),' On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(debug_unit,*) trim(name),' Tried reallocating for DCRJAD for ',& - & maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_sp_reall(b,nzr,info,ifc=ifc_) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - case ('COO') - - call ccoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcoco') - goto 9999 - end if - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - end select - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) then - call psb_sp_trim(b,info) - end if - - - call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_cspcnv2 - - -! -! Subroutine: psb_cspcnv1 -! This subroutine converts in place the storage format of a matrix. -! -! Arguments: -! -! a - type(psb_spmat_type), inout The input matrix to be converted. -! info - integer. Return code -! afmt - character, optional The desired storage format -! -subroutine psb_cspcnv1(a, info, afmt, upd, dupl) - - use psb_spmat_type - use psb_regen_mod - use psb_serial_mod, psb_protect_name => psb_cspcnv1 - use psb_const_mod - use psi_mod - use psb_error_mod - use psb_string_mod - !use psb_penv_mod - - implicit none - - - !...Parameters.... - type(psb_cspmat_type), intent (inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: afmt - - integer :: int_err(5) - type(psb_cspmat_type) :: atemp - integer :: err_act - integer :: spstate - integer :: upd_, dupl_ - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - logical :: inplace - - info = 0 - int_err(1)=0 - name = 'psb_spcnv' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,a,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,a,info) - end if - - upd_ = psb_sp_getifld(psb_upd_,a,info) - select case(upd_) - case(psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,a,info) - end select - - dupl_ = psb_sp_getifld(psb_dupl_,a,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,a,info) - end select - - - spstate = psb_sp_getifld(psb_state_,a,info) - if (info /= 0) then - goto 9999 - endif - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': Sparse matrix state:',& - & spstate,psb_spmat_bld_,psb_spmat_upd_ - if (spstate /= psb_spmat_upd_) then - ! Should we first figure out if we can do it in place? - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Update:',upd_,psb_upd_srch_,psb_upd_perm_ - inplace = .false. - if (upd_ == psb_upd_srch_) then - if (present(afmt)) then - select case (psb_toupper(a%fida)) - case('COO') - select case(psb_toupper(afmt)) - case('COO') - call psb_fixcoo(a,info) - inplace = .true. - case('CSR') - call psb_ipcoo2csr(a,info) - inplace = .true. - case('CSC') - call psb_ipcoo2csc(a,info) - inplace = .true. - end select - case('CSR') - select case(psb_toupper(afmt)) - case('COO') - call psb_ipcsr2coo(a,info) - inplace = .true. - end select - end select - end if - if (inplace) then - if (info == 0) call psb_sp_trim(a,info) - if (info /= 0) then - info=4010 - ch_err='inplace cnv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - call psb_erractionrestore(err_act) - return - end if - end if - - call psb_sp_clone(a,atemp,info) - if(info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_clone' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - ! convert to user requested format after the temp copy - end if - - ! Do the real conversion into the requested storage format - ! result is put in A - call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit, *) trim(name),& - & ': From SPCNV',info,' ',a%fida - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - call psb_sp_free(atemp,info) - - else if (spstate == psb_spmat_upd_) then - ! - ! Second case: we come from an update loop. - ! - select case(psb_toupper(a%fida)) - case('CSR') - call csr_regen(a,info) - case ('COO','COI') - call coo_regen(a,info) - case('JAD') - call jad_regen(a,info) - case default - info=136 - ch_err=a%fida - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (info /= psb_no_err_) then - info = 4010 - ch_err='xx_regen' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - else - - info = 600 - call psb_errpush(info,name) - goto 9999 - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ - - endif - - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_cspcnv1 diff --git a/base/serial/psb_cspgetrow.f90 b/base/serial/psb_cspgetrow.f90 deleted file mode 100644 index bc291712d..000000000 --- a/base/serial/psb_cspgetrow.f90 +++ /dev/null @@ -1,130 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cspgetrow.f90 -! Subroutine: psb_cspgetrow -! Gets one or more rows from a sparse matrix. -! Arguments: -! irw - integer, input The row to be extracted -! a - type(psb_cspmat_type),input The sparse matrix -! nz - integer, output The number of entries -! ia(:) - integer, allocatable, inout The output row indices -! ja(:) - integer, allocatable, inout The output col indices -! val(:) - complex, allocatable,inout The coefficients -! info - integer, output Error code -! iren(:) - integer, input,optional Renumbering of indices -! lrw - integer, input,optional Extract rows irw:lrw, default lrw=irw -! append - logical, input,optional Should we append to already existing -! partial output? -! nzin - integer, input, optional If appending, how many entries were already -! occupied. -! -subroutine psb_cspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) - ! Output is always in COO format - use psb_spmat_type - use psb_const_mod - use psb_getrow_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_cspgetrow - implicit none - - type(psb_cspmat_type), intent(in) :: a - integer, intent(in) :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: lrw, nzin - - logical :: append_ - integer :: nzin_, lrw_, irw_, err_act - character(len=20) :: name, ch_err - - name='psb_spgetrow' - info = 0 - - call psb_erractionsave(err_act) - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_=append - else - append_=.false. - endif - - - if ((append_).and.(present(nzin))) then - nzin_ = nzin - else - nzin_ = 0 - endif - - select case (psb_tolower(a%fida)) - case ('csr') - call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case ('coo') - call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case ('jad') - call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (info /= 0) goto 9999 -!!$ call psb_erractionrestore(err_act) - return - -9999 continue -!!$ call psb_erractionrestore(err_act) - call psb_erractionsave(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_cspgetrow - diff --git a/base/serial/psb_cspgtblk.f90 b/base/serial/psb_cspgtblk.f90 deleted file mode 100644 index 57232c029..000000000 --- a/base/serial/psb_cspgtblk.f90 +++ /dev/null @@ -1,114 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cspgtblk.f90 -! Subroutine: psb_cspgtblk -! Gets one or more rows from a sparse matrix. -! Arguments: -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, * -!* * -!***************************************************************************** -subroutine psb_cspgtblk(irw,a,b,info,append,iren,lrw,srt) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_cspgtblk - implicit none - - type(psb_cspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_cspmat_type), intent(inout) :: b - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - logical, intent(in), optional :: srt - - logical :: append_,srt_ - integer :: nz,nzb, lrw_, irw_ - character(len=20) :: name - - name='psb_spgtblk' - info = 0 - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_ = append - else - append_ = .false. - endif - - if (present(srt)) then - srt_ = srt - else - srt_ = .true. - endif - - - if (append_) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - b%m = 0 - b%k = 0 - b%descra = a%descra - endif - b%fida = 'COO' - - call psb_sp_getrow(irw,a,nz,b%ia1,b%ia2,b%aspk,info,iren=iren,& - & lrw=lrw_,append=append_,nzin=nzb) - if (info == 0) call psb_ensure_size(1,b%pl,info) - if (info == 0) call psb_ensure_size(1,b%pr,info) - if (info /= 0) return - b%pl = 0 - b%pr = 0 - b%infoa(psb_nnz_) = nzb+nz - b%m = b%m+lrw_-irw+1 - b%k = max(b%k,a%k) - if (srt_) call psb_fixcoo(b,info) - return - -end subroutine psb_cspgtblk - diff --git a/base/serial/psb_cspgtdiag.f90 b/base/serial/psb_cspgtdiag.f90 deleted file mode 100644 index a26cdda16..000000000 --- a/base/serial/psb_cspgtdiag.f90 +++ /dev/null @@ -1,123 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cspgtdiag.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* * -!***************************************************************************** -subroutine psb_cspgtdiag(a,d,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_serial_mod, psb_protect_name => psb_cspgtdiag - implicit none - - type(psb_cspmat_type), intent(in) :: a - complex(psb_spk_), intent(inout) :: d(:) - integer, intent(out) :: info - - type(psb_cspmat_type) :: tmpa - integer :: i,j, err_act, ii, rng, irb, nrb - character(len=20) :: name, ch_err - - name='psb_cspgtdiag' - info = 0 - call psb_erractionsave(err_act) - - if (size(d) < min(a%k,a%m)) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - d(:) = 0.d0 - if (a%fida == 'CSR') then - - do i=1, min(a%m,a%k) - do j=a%ia2(i),a%ia2(i+1)-1 - if (a%ia1(j) == i) then - d(i) = a%aspk(j) - end if - end do - end do - - else if (a%fida == 'COO') then - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - if ((j==a%ia2(i)).and.(j <= min(a%k,a%m)) .and.(j>0)) then - d(j) = a%aspk(i) - endif - enddo - - else if (a%fida == 'JAD') then - - rng=min(a%m,a%k) - nrb=16 - do i=1, rng, nrb - irb=min(i+nrb-1,rng) - call psb_sp_getblk(i,a,tmpa,info,lrw=irb) - if(info /= 0) then - info=4010 - ch_err='psb_spgtblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do ii=1,tmpa%infoa(psb_nnz_) - j=tmpa%ia1(ii) - if ((j==tmpa%ia2(ii)).and.(j <= rng) .and.(j>0)) then - d(j) = tmpa%aspk(ii) - endif - enddo - - end do - - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_cspgtdiag - diff --git a/base/serial/psb_cspscal.f90 b/base/serial/psb_cspscal.f90 deleted file mode 100644 index e17a6f707..000000000 --- a/base/serial/psb_cspscal.f90 +++ /dev/null @@ -1,158 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_cspscal.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* * -!***************************************************************************** -subroutine psb_cspscal(a,d,info) - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer, intent(out) :: info - complex(psb_spk_), intent(in) :: d(:) - - integer :: i,j, err_act - character(len=20) :: name, ch_err - - name='psb_cspscal' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_toupper(a%fida(1:3))) - case ('CSR') - - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - a%aspk(j) = a%aspk(j) * d(i) - end do - end do - - case ('COO') - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - a%aspk(i) = a%aspk(i) * d(j) - enddo - - case ('JAD') - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_cspscal -subroutine psb_cspscals(a,d,info) - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer, intent(out) :: info - complex(psb_spk_), intent(in) :: d - - integer :: i,j, err_act - character(len=20) :: name, ch_err - - name='psb_cspscal' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_toupper(a%fida(1:3))) - case ('CSR') - - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - a%aspk(j) = a%aspk(j) * d - end do - end do - - case ('COO') - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - a%aspk(i) = a%aspk(i) * d - enddo - - case ('JAD') - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_cspscals - diff --git a/base/serial/psb_ctransc.f90 b/base/serial/psb_ctransc.f90 deleted file mode 100644 index 40b45cf77..000000000 --- a/base/serial/psb_ctransc.f90 +++ /dev/null @@ -1,84 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ctransc.f90 -! Subroutine: -! Arguments: - -subroutine psb_ctransc(a,b,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_ctransc - implicit none - - type(psb_cspmat_type), intent(in) :: a - type(psb_cspmat_type), intent(out) :: b - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer :: c_, info, i - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_nullify_sp(b) - - call psb_spcnv(a,b,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(b%ia1,itmp,info) - call psb_move_alloc(b%ia2,b%ia1,info) - call psb_move_alloc(itmp,b%ia2,info) - - do i=1, b%infoa(psb_nnz_) - b%aspk(i) = conjg(b%aspk(i)) - end do - - b%m = a%k - b%k = a%m - call psb_spcnv(b,info,afmt=fmt_) - - return -end subroutine psb_ctransc diff --git a/base/serial/psb_ctransp.f90 b/base/serial/psb_ctransp.f90 deleted file mode 100644 index d015d7f3d..000000000 --- a/base/serial/psb_ctransp.f90 +++ /dev/null @@ -1,121 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ctransp.f90 -! Subroutine: -! Arguments: - -subroutine psb_ctransp(a,b,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_ctransp - implicit none - - type(psb_cspmat_type), intent(in) :: a - type(psb_cspmat_type), intent(out) :: b - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer :: c_, info - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_nullify_sp(b) - - call psb_spcnv(a,b,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(b%ia1,itmp,info) - call psb_move_alloc(b%ia2,b%ia1,info) - call psb_move_alloc(itmp,b%ia2,info) - - b%m = a%k - b%k = a%m - call psb_spcnv(b,info,afmt=fmt_) - - return -end subroutine psb_ctransp - -subroutine psb_ctransp1(a,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_ctransp1 - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer ::c_, info - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_spcnv(a,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(a%ia1,itmp,info) - call psb_move_alloc(a%ia2,a%ia1,info) - call psb_move_alloc(itmp,a%ia2,info) - - call psb_spcnv(a,info,afmt=fmt_) - - return -end subroutine psb_ctransp1 diff --git a/base/serial/psb_dcoins.f90 b/base/serial/psb_dcoins.f90 deleted file mode 100644 index 3706f23d3..000000000 --- a/base/serial/psb_dcoins.f90 +++ /dev/null @@ -1,622 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcoins.f90 -! Subroutine: psb_dcoins -! Takes a cloud of coefficients and inserts them into a sparse matrix. -! This subroutine is the serial, inner counterpart to the outer, user-level -! psb_spins. -! -! Arguments: -! -! nz - integer, input The number of points to insert. -! ia(:) - integer, input The row indices of the coefficients. -! ja(:) - integer, input The column indices of the coefficients. -! val(:) - real, input The values of the coefficients to be inserted. -! a - type(psb_dspmat_type), inout The sparse destination matrix. -! imin - integer, input The minimum valid row index -! imax - integer, input The maximum valid row index -! jmin - integer, input The minimum valid col index -! jmax - integer, input The maximum valid col index -! info - integer, output Return code. -! gtl(:) - integer, input,optional An index mapping to be applied -! default: identity -! rebuild - logical, input, optional Rebuild in case of update -! finding a new index. Default: false. -! Not fully tested. -! -subroutine psb_dcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_error_mod - use psb_serial_mod, psb_protect_name => psb_dcoins - use psb_update_mod - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax - integer, intent(in) :: ia(:),ja(:) - real(psb_dpk_), intent(in) :: val(:) - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - logical, intent(in), optional :: rebuild - - character(len=5) :: ufida - integer :: ng, nza, isza,spstate, & - & ip1, nzl, err_act, int_err(5), iupd, irst - integer :: debug_level, debug_unit - logical :: rebuild_ - character(len=20) :: name, ch_err - type(psb_dspmat_type) :: tmp - - name='psb_dcoins' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - info = 0 - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (present(rebuild)) then - rebuild_ = rebuild - else - rebuild_ = .false. - end if - - ufida = psb_toupper(a%fida) - spstate = psb_sp_getifld(psb_state_,a,info) - - - if (present(gtl)) then - - ng = size(gtl) - select case(spstate) - case(psb_spmat_bld_) - if ((ufida /= 'COO').and.(ufida/='COI')) then - info = 134 - ch_err(1:3)=ufida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info,gtl,ng) - - if(info /= izero) then - - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%infoa(psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': insert discarded items ' - end if - end if - if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - endif - call psb_sp_setifld(nza,psb_nnz_,a,info) - - case(psb_spmat_upd_) - - iupd = psb_sp_getifld(psb_upd_,a,info) - select case (iupd) - case (psb_upd_perm_) - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - nzl = psb_sp_getifld(psb_del_bnd_,a,info) - select case(ufida) - case ('JAD') - nza = a%ia1(ip1+psb_nnz_) - case default - nza = a%ia2(ip1+psb_nnz_) - end select - - call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - if (info /= izero) then - ch_err='psb_inner_upd' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': update discarded items ' - end if - end if - - select case(ufida) - case ('JAD') - a%ia1(ip1+psb_nnz_) = nza - case default - a%ia2(ip1+psb_nnz_) = nza - end select - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': (UPD) : NZA:',nza - - case (psb_upd_srch_) - - call psb_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - if (info > 0) then - if (rebuild_) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*)& - & trim(name),& - & ': Going through rebuild_ fingers crossed!' - irst = info - call psb_nullify_sp(tmp) - call psb_spcnv(a,tmp,info,afmt='coo') - if(info /= izero) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst - call psb_move_alloc(tmp,a,info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_transfer' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) write(debug_unit,*)& - & trim(name),': Reinserting',a%fida,nza,isza,irst,nz - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - if (irst <= nz) then - call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& - & nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - &imin,imax,jmin,jmax,info,gtl,ng) - if (info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - endif - - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - call psb_sp_setifld(nza,psb_nnz_,a,info) - end if - - else - info = 2231 - call psb_errpush(info,name) - goto 9999 - end if - else if (info < 0) then - info = 2230 - call psb_errpush(info,name) - goto 9999 - - end if - - case default - - info = 2231 - call psb_errpush(info,name) - goto 9999 - end select - - - case default - info = 2232 - call psb_errpush(info,name) - goto 9999 - end select - - - - - - else - - ng = -1 - - select case(spstate) - case(psb_spmat_bld_) - if ((ufida /= 'COO').and.(ufida/='COI')) then - info = 134 - ch_err(1:3)=ufida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info) - - if(info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%infoa(psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': insert discarded items ' - end if - end if - if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - endif - call psb_sp_setifld(nza,psb_nnz_,a,info) - - case(psb_spmat_upd_) - - iupd = psb_sp_getifld(psb_upd_,a,info) - select case (iupd) - case (psb_upd_perm_) - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - nzl = psb_sp_getifld(psb_del_bnd_,a,info) - nza = a%ia2(ip1+psb_nnz_) - - - call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& - & imin,imax,jmin,jmax,nzl,info) - if (info /= izero) then - ch_err='psb_inner_upd' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) then - if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': update discarded items ' - end if - end if - a%ia2(ip1+psb_nnz_) = nza - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),':(UPD) : NZA:',nza - - case (psb_upd_srch_) - - call psb_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) - - if (info > 0) then - if (rebuild_) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*)& - & trim(name),& - & ': Going through rebuild_ fingers crossed!' - irst = info - call psb_nullify_sp(tmp) - call psb_spcnv(a,tmp,info,afmt='coo') - call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst - call psb_move_alloc(tmp,a,info) - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) write(debug_unit,*)& - & trim(name),': Reinserting',a%fida,nza,isza - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - if (irst <= nz) then - call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& - & nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info) - if (info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - endif - - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - call psb_sp_setifld(nza,psb_nnz_,a,info) - end if - - else - info = 2231 - call psb_errpush(info,name) - goto 9999 - end if - else if (info < 0) then - info = 2230 - call psb_errpush(info,name) - goto 9999 - - end if - - case default - - info = 2233 - call psb_errpush(info,name) - goto 9999 - end select - - - case default - info = 2232 - call psb_errpush(info,name) - goto 9999 - end select - endif - - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -contains - - subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,maxsz,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,maxsz - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - real(psb_dpk_), intent(in) :: val(:) - real(psb_dpk_), intent(inout) :: aspk(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic - character(len=20) :: name, ch_err - - - name='psb_inner_upd' - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - if ((nza > nzl)) then - do i=1, nz - nza = nza + 1 - if (nza>maxsz) then - call psb_errpush(50,name,i_err=(/7,maxsz,5,0,nza /)) - info = -71 - return - endif - aspk(nza) = val(i) - end do - else - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza>maxsz) then - info = -72 - return - endif - aspk(nza) = val(i) - end if - end if - end do - end if - else - if ((nza >= nzl)) then - do i=1, nz - nza = nza + 1 - if (nza>maxsz) then - info = -73 - return - endif - aspk(nza) = val(i) - end do - else - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza>maxsz) then - info = -74 - return - endif - aspk(nza) = val(i) - end if - end do - end if - end if - end subroutine psb_inner_upd - - subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& - & imin,imax,jmin,jmax,info,gtl,ng) - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza,ia1(:),ia2(:) - real(psb_dpk_), intent(in) :: val(:) - real(psb_dpk_), intent(inout) :: aspk(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic - - info = 0 - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza > maxsz) then - info = -91 - return - endif - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end if - end do - else - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza > maxsz) then - info = -92 - return - endif - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end do - end if - - end subroutine psb_inner_ins - - - -end subroutine psb_dcoins - diff --git a/base/serial/psb_dcsmm.f90 b/base/serial/psb_dcsmm.f90 deleted file mode 100644 index 0a9369ad8..000000000 --- a/base/serial/psb_dcsmm.f90 +++ /dev/null @@ -1,113 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcsmm.f90 -! Subroutine: -! Arguments: -subroutine psb_dcsmm(alpha,a,b,beta,c,info,trans) - use psb_spmat_type, psb_protect_name => psb_dcsmm - use psb_error_mod - implicit none - - class(psb_dspmat_type) :: a - real(psb_dpk_) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans - - real(psb_dpk_), allocatable :: work(:) - character :: trans_ - integer :: iwsz,m,n,k,lb,lc,err_act - character(len=20) :: name, ch_err - - name='psb_dcsmm' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if (trans_=='N') then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - n = min(size(b,2),size(c,2)) - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz),stat=info) - if (info /= 0) then - info = 4010 - ch_err='allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call dcsmm(trans_,m,n,k,alpha,& - & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - - if (info /= 0) then - info = 4010 - ch_err='Serial csmm' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - goto 9999 - end if - deallocate(work,stat=info) - - if (info /= 0) then - info = 4010 - ch_err='Deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return -end subroutine psb_dcsmm diff --git a/base/serial/psb_dcsmv.f90 b/base/serial/psb_dcsmv.f90 deleted file mode 100644 index dc556a053..000000000 --- a/base/serial/psb_dcsmv.f90 +++ /dev/null @@ -1,90 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcsmv.f90 -! Subroutine: -! Arguments: - -subroutine psb_dcsmv(alpha,a,b,beta,c,info,trans) - use psb_spmat_type, psb_protect_name => psb_dcsmv - use psb_error_mod - implicit none - - class(psb_dspmat_type) :: a - real(psb_dpk_) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans - - real(psb_dpk_), allocatable :: work(:) - character :: trans_ - integer :: iwsz,m,n,k,lb,lc, err_act - character(len=20) :: name - - name='psb_dcsmv' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if (trans_=='N') then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - n = 1 - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call dcsmm(trans_,m,n,k,alpha,& - & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_dcsmv diff --git a/base/serial/psb_dcsnmi.f90 b/base/serial/psb_dcsnmi.f90 deleted file mode 100644 index 1df80bc70..000000000 --- a/base/serial/psb_dcsnmi.f90 +++ /dev/null @@ -1,93 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcsnmi.f90 -! Subroutine: -! Arguments: - -function psb_dcsnmi(a,info,trans) - - use psb_spmat_type - use psb_error_mod - implicit none - - type(psb_dspmat_type), intent(in) :: a - integer, intent(out) :: info - character, optional :: trans - real(psb_dpk_) :: psb_dcsnmi - interface - function dcsnmi(trans,m,n,fida,descra,a,ia1,ia2,& - & infoa,ierror) - use psb_const_mod - real(psb_dpk_) :: dcsnmi - integer :: m,n, ierror - character :: trans - integer :: ia1(*),ia2(*),infoa(*) - character :: descra*11, fida*5 - real(psb_dpk_) :: a(*) - end function dcsnmi - end interface - - integer :: err_act - character :: itrans - character(len=20) :: name, ch_err - - name='psb_dcsnmi' - call psb_erractionsave(err_act) - - if(present(trans)) then - itrans=trans - else - itrans='N' - end if - - psb_dcsnmi = dcsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info) - if(info/=0) then - psb_dcsnmi = -1 - info=4010 - ch_err='psb_dcsnmi' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end function psb_dcsnmi diff --git a/base/serial/psb_dcsprt.f90 b/base/serial/psb_dcsprt.f90 deleted file mode 100644 index 005057671..000000000 --- a/base/serial/psb_dcsprt.f90 +++ /dev/null @@ -1,199 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcsprt.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* Print out a matrix. * -!* Should really align with the F77 version under the SERIAL dir, which * -!* does a nice printout in MatrixMarket format; this would be a quick job. * -!* * -!* Handles both a shift in the row/col indices and a fuctional transform * -!* on the indices. * -!* * -!* * -!* * -!* * -!***************************************************************************** -subroutine psb_dcsprt(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_spmat_type - use psb_string_mod - implicit none - - integer, intent(in) :: iout - type(psb_dspmat_type), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% ',psb_toupper(a%fida) - endif - - nmx = max(a%m,a%k,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es26.18,1x,2(i',ni,',1x))' - - - select case(psb_toupper(a%fida)) - - case ('CSR') - - write(iout,*) a%m,a%k,a%ia2(a%m+1)-1 - - if (present(iv)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) iv(irs+i),iv(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+i),(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+i),ivc(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+i),ivc(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+i),(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - endif - endif - - case ('CSC') - - write(iout,*) a%m,a%k,a%ia2(a%k+1)-1 - - if (present(iv)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) iv(irs+a%ia1(j)),iv(ics+i),a%aspk(j) - enddo - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+a%ia1(j)),(ics+i),a%aspk(j) - enddo - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+a%ia1(j)),ivc(ics+i),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+a%ia1(j)),ivc(ics+i),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+a%ia1(j)),(ics+i),a%aspk(j) - enddo - enddo - endif - endif - - case ('COO') - if(present(iv)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) iv(a%ia1(j)),iv(a%ia2(j)),a%aspk(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) ivr(a%ia1(j)),a%ia2(j),a%aspk(j) - enddo - else if (present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) ivr(a%ia1(j)),ivc(a%ia2(j)),a%aspk(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) a%ia1(j),ivc(a%ia2(j)),a%aspk(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) a%ia1(j),a%ia2(j),a%aspk(j) - enddo - endif - endif - case default - write(0,*) 'Feeling lazy today, format not implemented: "',a%fida,'"' - end select - -end subroutine psb_dcsprt diff --git a/base/serial/psb_dcsrp.f90 b/base/serial/psb_dcsrp.f90 deleted file mode 100644 index 0f25555a5..000000000 --- a/base/serial/psb_dcsrp.f90 +++ /dev/null @@ -1,157 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcsrp.f90 -! -! -! Subroutine: psb_dcsrp -! Apply a right permutation to a sparse matrix, i.e. permute the column -! indices. -! -! Arguments: -! trans - character. Whether iperm or its transpose -! should be applied -! iperm - integer, dimension(:) A permutation vector; its size -! must be either N_ROW or N_COL -! a - type(psb_dspmat_type). The matrix to be permuted -! info - integer. Eventually returns an error code -subroutine psb_dcsrp(trans,iperm,a, info) - use psb_serial_mod, psb_protect_name => psb_dcsrp - use psb_const_mod - ! implicit none - - interface dcsrp - - subroutine dcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - real(psb_dpk_), intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine dcsrp - end interface - - - !...parameters.... - type(psb_dspmat_type), intent(inout) :: a - integer, intent(inout) :: iperm(:), info - character, intent(in) :: trans - !....locals.... - integer,allocatable :: ipt(:) - integer :: i, n_col,l_dcsdp, ipsize - real(psb_dpk_), allocatable :: work_dcsdp(:) - integer :: n_row,err_act, int_err(5) - character(len=20) :: name, char_err - - n_row = psb_sp_get_nrows(a) - n_col = psb_sp_get_ncols(a) - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - name = 'psd_csrp' - - ipsize = size(iperm) - if (.not.((ipsize == n_col).or.(ipsize == n_row) )) then - info = 35 - int_err(1) = 1 - int_err(2) = ipsize - call psb_errpush(info,name,int_err) - goto 9999 - else - if (.not.psb_isaperm(ipsize,iperm)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - l_dcsdp = (n_col) - - call psb_realloc(l_dcsdp,work_dcsdp,info) - call psb_realloc(n_col,ipt,info) - if(info /= psb_no_err_) then - info=4010 - char_err='psrealloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - end if - - if (ipsize == n_col) then - do i=1, n_col - ipt(i) = iperm(i) - enddo - else - do i=1, n_row - ipt(i) = iperm(i) - enddo - do i=n_row+1,n_col - ipt(i) = i - enddo - endif - ! crossed fingers..... - ! fix glob_to_loc/loc_to_glob mappings, then indices lists - ! hmm, maybe we should just move all of this onto a different level, - ! have a specialized subroutine, and do it in the solver context???? - call dcsrp(trans,n_row,n_col,a%fida,a%descra,a%ia1,a%ia2,a%infoa,& - & ipt,work_dcsdp,size(work_dcsdp),info) - if(info /= psb_no_err_) then - info=4010 - char_err='dcsrp' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - end if - - deallocate(ipt,work_dcsdp,stat=info) - if(info /= psb_no_err_) then - info=4010 - char_err='Deallocate' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dcsrp diff --git a/base/serial/psb_dcsrws.f90 b/base/serial/psb_dcsrws.f90 deleted file mode 100644 index 492354cd9..000000000 --- a/base/serial/psb_dcsrws.f90 +++ /dev/null @@ -1,105 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcsrws.f90 -! Subroutine: -! Arguments: - -subroutine psb_dcsrws(rw,a,info,trans) - use psb_spmat_type - use psb_error_mod - implicit none - - type(psb_dspmat_type) :: a - real(psb_dpk_), allocatable :: rw(:) - integer :: info - character, optional :: trans - - Interface - subroutine dcsrws(trans,m,n,fida,descra,a,ia1,ia2,& - & infoa,rowsum,ierror) - use psb_const_mod - integer, intent(in) :: m,n - integer, intent(out) :: ierror - real(psb_dpk_), intent(in) :: a(*) - real(psb_dpk_), intent(out) :: rowsum(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: descra*11,fida*5,trans*1 - end subroutine dcsrws - end interface - - character :: trans_ - integer :: m,k,err_act - character(len=20) :: name - - name='psb_dcsrws' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if (trans_=='N') then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - - if (size(rw) < m) then - call psb_realloc(m,rw,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - end if - - call dcsrws(trans,m,k,a%fida,a%descra,& - & a%aspk,a%ia1,a%ia2,a%infoa,rw,info) - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dcsrws diff --git a/base/serial/psb_dcssm.f90 b/base/serial/psb_dcssm.f90 deleted file mode 100644 index 07367563d..000000000 --- a/base/serial/psb_dcssm.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcssm.f90 -! Subroutine: -! Arguments: - -subroutine psb_dcssm(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type, psb_protect_name => psb_dcssm - use psb_error_mod - implicit none - - class(psb_dspmat_type) :: t - real(psb_dpk_) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans, unitd - real(psb_dpk_), optional, target :: d(:) - - real(psb_dpk_), allocatable :: work(:) - real(psb_dpk_), pointer :: ddl(:) - character :: lt, lu - integer :: iwsz,m,n,lb,lc,err_act - character(len=20) :: name - - name='psb_dcssm' - info = 0 - call psb_erractionsave(err_act) - - - if (present(trans)) then - lt = trans - else - lt = 'N' - endif - if (present(unitd)) then - lu = unitd - else - lu = 'U' - endif - if (present(d)) then - ddl => d - else - allocate(ddl(1)) - endif - - m = t%m - n = min(size(b,2),size(c,2)) - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call dcssm(lt,m,n,alpha,lu,ddl,& - & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - if (.not.present(d)) then - deallocate(ddl) - endif - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_dcssm diff --git a/base/serial/psb_dcssv.f90 b/base/serial/psb_dcssv.f90 deleted file mode 100644 index 15516566d..000000000 --- a/base/serial/psb_dcssv.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dcssv.f90 -! Subroutine: -! Arguments: - -subroutine psb_dcssv(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type, psb_protect_name => psb_dcssv - use psb_error_mod - implicit none - - class(psb_dspmat_type) :: t - real(psb_dpk_) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans, unitd - real(psb_dpk_), optional, target :: d(:) - - real(psb_dpk_), allocatable :: work(:) - real(psb_dpk_), pointer :: ddl(:) - character :: lt, lu - integer :: iwsz,m,n,lb,lc,err_act - character(len=20) :: name - - name='psb_dcssv' - info = 0 - call psb_erractionsave(err_act) - - - if (present(trans)) then - lt = trans - else - lt = 'N' - endif - if (present(unitd)) then - lu = unitd - else - lu = 'U' - endif - if (present(d)) then - ddl => d - else - allocate(ddl(1)) - endif - - m = t%m - n = 1 - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call dcssm(lt,m,n,alpha,lu,ddl,& - & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - if (.not.present(d)) then - deallocate(ddl) - endif - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_dcssv diff --git a/base/serial/psb_dfixcoo.f90 b/base/serial/psb_dfixcoo.f90 deleted file mode 100644 index 4d87bf6be..000000000 --- a/base/serial/psb_dfixcoo.f90 +++ /dev/null @@ -1,269 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dfixcoo.f90 -! Subroutine: -! Arguments: - -subroutine psb_dfixcoo(a,info,idir) - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dfixcoo - use psb_ip_reord_mod - use psb_error_mod - implicit none - - !....Parameters... - Type(psb_dspmat_type), intent(inout) :: A - Integer, intent(out) :: info - integer, intent(in), optional :: idir - - integer, allocatable :: iaux(:) - !locals - Integer :: nza, nzl,iret,idir_, dupl_ - integer :: i,j, irw, icl, err_act - integer :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(a%ia1),size(a%ia2) - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) 'Fixcoo Invalid input ',a%fida - info = -1 - return - end if - if (present(idir)) then - idir_ = idir - else - idir_ = 0 - endif - - nza = psb_sp_getifld(psb_nnz_,a,info) - if (nza < 2) return - - dupl_ = psb_sp_getifld(psb_dupl_,a,info) - - allocate(iaux(nza+2),stat=info) - if (info /= 0) return - - select case(idir_) - - case(0) ! Row major order - - call msort_up(nza,a%ia1(1),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nza,a%aspk,a%ia1,a%ia2,iaux) - i = 1 - j = i - do while (i <= nza) - do while ((a%ia1(j) == a%ia1(i))) - j = j+1 - if (j > nza) exit - enddo - nzl = j - i - call msort_up(nzl,a%ia2(i),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,a%aspk(i:i+nzl-1),& - & a%ia1(i:i+nzl-1),a%ia2(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = a%ia1(i) - icl = a%ia2(i) - j = 1 - - select case(dupl_) - case(psb_dupl_ovwrt_) - - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_add_) - - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - call psb_errpush(130,name) - goto 9999 - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - end select - - - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - case(1) ! Col major order - - call msort_up(nza,a%ia2(1),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nza,a%aspk,a%ia1,a%ia2,iaux) - i = 1 - j = i - do while (i <= nza) - do while ((a%ia2(j) == a%ia2(i))) - j = j+1 - if (j > nza) exit - enddo - nzl = j - i - call msort_up(nzl,a%ia1(i),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,a%aspk(i:i+nzl-1),& - & a%ia1(i:i+nzl-1),a%ia2(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = a%ia1(i) - icl = a%ia2(i) - j = 1 - - - select case(dupl_) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - call psb_errpush(130,name) - goto 9999 - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - end select - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - case default - write(debug_unit,*) trim(name),': unknown direction ',idir_ - end select - - call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info) - call psb_sp_setifld(i,psb_nnz_,a,info) - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info) - - deallocate(iaux) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_dfixcoo diff --git a/base/serial/psb_dgelp.f90 b/base/serial/psb_dgelp.f90 deleted file mode 100644 index 85ad775dd..000000000 --- a/base/serial/psb_dgelp.f90 +++ /dev/null @@ -1,252 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dgelp.f90 -! -! -! Subroutine: psb_dgelp -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:,:). -! info - integer. Return code. -subroutine psb_dgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_dgelp - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_dpk_), intent(inout) :: x(:,:) - integer, intent(in) :: iperm(:) - integer, intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer :: ictxt - real(psb_dpk_),allocatable :: dtemp(:) - integer :: int_err(5), i1sz, i2sz, err_act - integer, allocatable :: itemp(:) - real(psb_dpk_),parameter :: one=1 - integer :: debug_level, debug_unit - - interface dgelp - subroutine dgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - real(psb_dpk_), intent(inout) :: b(ldb,*), work(*) - integer, intent(in) :: p(*) - end subroutine dgelp - end interface - - character(len=20) :: name, ch_err - name = 'psb_dgelp' - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - - call dgelp(trans,i1sz,i2sz,itemp,x,i1sz,dtemp,i1sz,info) - if(info /= 0) then - info=4010 - ch_err='dgelp' - call psb_errpush(info,name,a_err=ch_err) - end if - - deallocate(dtemp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_dgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! -! Subroutine: psb_dgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_dgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_dgelpv - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_dpk_), intent(inout) :: x(:) - integer, intent(in) :: iperm(:) - integer, intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer :: ictxt - integer :: int_err(5), i1sz, err_act - real(psb_dpk_),allocatable :: dtemp(:) - integer, allocatable :: itemp(:) - real(psb_dpk_),parameter :: one=1 - integer :: debug_level, debug_unit - - interface dgelp - subroutine dgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - real(psb_dpk_), intent(inout) :: b(*), work(*) - integer, intent(in) :: p(*) - end subroutine dgelp - end interface - - character(len=20) :: name, ch_err - name = 'psb_dgelpv' - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - call dgelp(trans,i1sz,1,itemp,x,i1sz,dtemp,i1sz,info) - if(info /= 0) then - info=4010 - ch_err='dgelp' - call psb_errpush(info,name,a_err=ch_err) - end if - - deallocate(dtemp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_dgelpv - diff --git a/base/serial/psb_dipcoo2csc.f90 b/base/serial/psb_dipcoo2csc.f90 deleted file mode 100644 index 324657ce3..000000000 --- a/base/serial/psb_dipcoo2csc.f90 +++ /dev/null @@ -1,221 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dipcoo2csc.f90 -! Subroutine: -! Arguments: - -subroutine psb_dipcoo2csc(a,info,clshr) - use psb_spmat_type - use psb_const_mod - use psb_serial_mod, psb_protect_name => psb_dipcoo2csc - use psb_error_mod - use psb_string_mod - use psb_realloc_mod - implicit none - - !....Parameters... - Type(psb_dspmat_type), intent(inout) :: A - Integer, intent(out) :: info - logical, optional :: clshr - - integer, allocatable :: iaux(:), itemp(:) - !locals - logical :: clshr_ - Integer :: nza, i,j, idl,err_act,nc,icl - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name - - name='psb_ipcoo2csc' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) write(debug_unit,*) & - & trim(name),': start',a%fida,a%m - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) trim(name),' Invalid input ',a%fida - info = -1 - call psb_errpush(info,name) - goto 9999 - end if - if (present(clshr)) then - clshr_ = clshr - else - clshr_ = .false. - end if - - call psb_fixcoo(a,info,idir=1) - if (info == 0) then - nc = a%k - nza = a%infoa(psb_nnz_) - allocate(iaux(max(nc+1,1)),stat=info) - end if - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nc+1,1),0,0,0,0/)) - goto 9999 - end if - if(debug_level >= psb_debug_serial_) write(debug_unit,*) trim(name),& - & ': out of fixcoo',nza,nc,size(a%ia2),size(iaux) - - call psb_move_alloc(a%ia2,itemp,info) - if (info == 0) call psb_move_alloc(iaux,a%ia2,info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_move_alloc') - goto 9999 - end if - - ! - ! This routine can be used in two modes: - ! 1. Normal: just look at the col indices and trust them. This - ! implies putting in empty cols where needed. In this case you - ! can get in trouble if A%M < A%IA1(NZA) - ! 2. Shrink mode: disregard the actual value of the col indices, - ! just treat them as ident markers. In this case you can get in - ! trouble when the number of distinct col indices is greater - ! than A%M - ! - ! - - a%ia2(1) = 1 - - if (nza <= 0) then - do i=1,nc - a%ia2(i+1) = a%ia2(i) - end do - else - - if (clshr_) then - - j = 1 - i = 1 - icl = itemp(j) - - do j=1, nza - if (itemp(j) /= icl) then - a%ia2(i+1) = j - icl = itemp(j) - i = i + 1 - if (i>nc) then - write(debug_unit,*) trim(name),': CLSHR=.true. : ',& - & i, nc,' Expect trouble!' - exit - end if - endif - enddo -! write(debug_unit,*) 'Exit from loop',j,nza,i - do - if (i>=nc+1) exit - a%ia2(i+1) = j - i = i + 1 - end do - - else - - if (nc < itemp(nza)) then - write(debug_unit,*) trim(name),': CLSHR=.false. : ',& - &nc,itemp(nza),' Expect trouble!' - end if - - - j = 1 - i = 1 - icl = itemp(j) - - outer: do - inner: do - if (i >= icl) exit inner - if (i>nc) then - write(debug_unit,*) trim(name),& - & 'strange situation: i>nc ',i,nc,j,nza,icl,idl - exit outer - end if - a%ia2(i+1) = a%ia2(i) - i = i + 1 - end do inner - j = j + 1 - if (j > nza) exit - if (itemp(j) /= icl) then - if (i>nc) then - write(debug_unit,*) trim(name), & - &'Strange situation: ',i,nc,size(a%ia2),& - & nza,j,itemp(j) - end if - a%ia2(i+1) = j - icl = itemp(j) - i = i + 1 - endif - if (i>nc) exit - enddo outer - ! - ! Cleanup empty cols at the end - ! - if (j /= (nza+1)) then - write(debug_unit,*) trim(name),': Problem from loop :',j,nza,itemp(j) - endif - do - if (i>nc) exit - a%ia2(i+1) = j - i = i + 1 - end do - - endif - - end if - -!!$ write(debug_unit,*) 'IPcoo2csc end loop ',i,nc,a%ia2(nc+1),nza - a%fida='CSC' - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp,stat=info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='deallocate') - goto 9999 - end if - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_dipcoo2csc diff --git a/base/serial/psb_dipcoo2csr.f90 b/base/serial/psb_dipcoo2csr.f90 deleted file mode 100644 index 9a0679b3b..000000000 --- a/base/serial/psb_dipcoo2csr.f90 +++ /dev/null @@ -1,213 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dipcoo2csr.f90 -! Subroutine: -! Arguments: - -subroutine psb_dipcoo2csr(a,info,rwshr) - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_serial_mod, psb_protect_name => psb_dipcoo2csr - use psb_error_mod - use psb_string_mod - implicit none - - !....Parameters... - Type(psb_dspmat_type), intent(inout) :: A - Integer, intent(out) :: info - logical, optional :: rwshr - - integer, allocatable :: iaux(:), itemp(:) - !locals - logical :: rwshr_ - Integer :: nza, nr, i,j,irw, idl,err_act - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name - - name='psb_ipcoo2csr' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': start',a%fida,a%m - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) trim(name),': Invalid input ',a%fida - info = -1 - call psb_errpush(info,name) - goto 9999 - end if - if (present(rwshr)) then - rwshr_ = rwshr - else - rwshr_ = .false. - end if - - call psb_fixcoo(a,info) - nr = a%m - nza = a%infoa(psb_nnz_) - allocate(iaux(max(nr+1,1)),stat=info) - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nr+1,1),0,0,0,0/)) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & ': out of fixcoo',nza,nr,size(a%ia2),size(iaux) - - call psb_move_alloc(a%ia1,itemp,info) - call psb_move_alloc(a%ia2,a%ia1,info) - call psb_move_alloc(iaux,a%ia2,info) - - ! - ! This routine can be used in two modes: - ! 1. Normal: just look at the row indices and trust them. This - ! implies putting in empty rows where needed. In this case you - ! can get in trouble if A%M < A%IA1(NZA) - ! 2. Shrink mode: disregard the actual value of the row indices, - ! just treat them as ident markers. In this case you can get in - ! trouble when the number of distinct row indices is greater - ! than A%M - ! - ! - - a%ia2(1) = 1 - - if (nza <= 0) then - do i=1,nr - a%ia2(i+1) = a%ia2(i) - end do - else - - if (rwshr_) then - - - j = 1 - i = 1 - irw = itemp(j) - - do j=1, nza - if (itemp(j) /= irw) then - a%ia2(i+1) = j - irw = itemp(j) - i = i + 1 - if (i>nr) then - write(debug_unit,*) trim(name),': RWSHR=.true. : ',& - & i, nr,' Expect trouble!' - exit - end if - endif - enddo - do - if (i>=nr+1) exit - a%ia2(i+1) = j - i = i + 1 - end do - - else - - if (nr < itemp(nza)) then - write(debug_unit,*) trim(name),': RWSHR=.false. : ',& - &nr,itemp(nza),' Expect trouble!' - info = 12 - end if - - - j = 1 - i = 1 - irw = itemp(j) - - outer: do - inner: do - if (i >= irw) exit inner - if (i>nr) then - write(debug_unit,*) trim(name),& - & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl - exit outer - end if - a%ia2(i+1) = a%ia2(i) - i = i + 1 - end do inner - j = j + 1 - if (j > nza) exit - if (itemp(j) /= irw) then - a%ia2(i+1) = j - irw = itemp(j) - i = i + 1 - endif - if (i>nr) exit - enddo outer - ! - ! Cleanup empty rows at the end - ! - if (j /= (nza+1)) then - write(debug_unit,*) trim(name),': Problem from loop :',j,nza - info = 13 - endif - do - if (i>nr) exit - a%ia2(i+1) = j - i = i + 1 - end do - - endif - - end if - - a%fida='CSR' - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp,stat=info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='deallocate') - goto 9999 - end if - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_dipcoo2csr diff --git a/base/serial/psb_dipcsr2coo.f90 b/base/serial/psb_dipcsr2coo.f90 deleted file mode 100644 index 9777681be..000000000 --- a/base/serial/psb_dipcsr2coo.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dipcsr2coo.f90 -! Subroutine: -! Arguments: - -Subroutine psb_dipcsr2coo(a,info) - use psb_spmat_type - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_realloc_mod - use psb_serial_mod, psb_protect_name => psb_dipcsr2coo - implicit none - - !....Parameters... - Type(psb_dspmat_type), intent(inout) :: A - Integer, intent(out) :: info - - !locals - Integer :: nza, nr - integer :: i,j,err_act - integer, allocatable :: iaux(:), itemp(:) - character(len=20) :: name='psb_dipcsr2coo' - - info = 0 - call psb_erractionsave(err_act) - - if (psb_toupper(a%fida) /= 'CSR') then - info = 5 - call psb_errpush(info,name) - goto 9999 - end if - - nr = a%m - nza = a%ia2(nr+1) - 1 - allocate(iaux(max(nza,1)),stat=info) - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nza,1),0,0,0,0/)) - goto 9999 - end if -!!$ write(0,*) 'ipcsr2coo ',a%m - call psb_move_alloc(a%ia2,itemp,info) - call psb_move_alloc(a%ia1,a%ia2,info) - call psb_move_alloc(iaux,a%ia1,info) - - do i=1, nr - do j=itemp(i),itemp(i+1)-1 - a%ia1(j) = i - end do - end do - - a%fida='COO' - a%infoa(psb_nnz_) = nza - a%infoa(psb_srtd_) = psb_isrtdcoo_ - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp) - call psb_fixcoo(a,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_dipcsr2coo diff --git a/base/serial/psb_dneigh.f90 b/base/serial/psb_dneigh.f90 deleted file mode 100644 index 71a9c120e..000000000 --- a/base/serial/psb_dneigh.f90 +++ /dev/null @@ -1,121 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dneigh.f90 -! Subroutine: -! Arguments: - -subroutine psb_dneigh(a,idx,neigh,n,info,lev) - - use psb_realloc_mod - use psb_const_mod - use psb_spmat_type - use psb_serial_mod, psb_protect_name => psb_dneigh - implicit none - - - type(psb_dspmat_type), intent(in) :: a ! the sparse matrix - integer, intent(in) :: idx ! the index whose neighbours we want to find - integer, intent(out) :: n, info ! the number of neighbours and the info - integer, allocatable :: neigh(:) ! the neighbours - integer, optional, intent(in) :: lev ! level of neighbours to find - - integer :: lev_, i, nl, ifl,ill,& - & n1, err_act, nn, nidx,ntl - character(len=20) :: name - integer, allocatable :: ia(:), ja(:) - real(psb_dpk_), allocatable :: val(:) - - name='psb_dneigh' - info = 0 - call psb_erractionsave(err_act) - - n = 0 - info = 0 - if(present(lev)) then - lev_=lev - else - lev_=1 - end if - - call psb_sp_getrow(idx,a,n,ia,ja,val,info) - if (info == 0) call psb_realloc(n,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(1:n) = ja(1:n) - ifl = 1 - ill = n - - - do nl = 2, lev_ - n1 = ill - ifl + 1 - call psb_ensure_size(ill+n1*n1,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - ntl = 0 - do i=ifl,ill - nidx=neigh(i) - if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then - call psb_sp_getrow(nidx,a,nn,ia,ja,val,info) - if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) - ntl = ntl+nn - end if - end do - call psb_msort_unique(neigh(ill+1:ill+ntl),nn) - ifl = ill + 1 - ill = ill + nn - end do - call imsru(ill,neigh,psb_sort_up_,nn) - n = nn - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_dneigh - diff --git a/base/serial/psb_dspclip.f90 b/base/serial/psb_dspclip.f90 deleted file mode 100644 index 5a4e16e28..000000000 --- a/base/serial/psb_dspclip.f90 +++ /dev/null @@ -1,157 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspclip.f90 -! Subroutine: psb_dspclip -! Creates a "clipped" copy of input matrix A. Output is always in COO. -! Arguments: - -!***************************************************************************** -!* * -!***************************************************************************** -subroutine psb_dspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dspclip - implicit none - type(psb_dspmat_type), intent(in) :: a - type(psb_dspmat_type), intent(out) :: b - integer, intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - integer :: err_act - character(len=20) :: name - integer :: imin_,imax_,jmin_,jmax_ - logical :: rscale_,cscale_ - integer :: sizeb, nzb, mb, kb, ifst, ilst, nrt, nzt, i, j - integer, parameter :: irbk=40 - - name='psb_dsp_clip' - info = 0 - call psb_erractionsave(err_act) - call psb_set_erraction(0) - - call psb_nullify_sp(b) - - - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - endif - if (present(imax)) then - imax_ = imax - else - imax_ = a%m - endif - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%k - endif - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - endif - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - endif - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%m ! Should this be imax_ ?? - endif - if (cscale_) then - kb = jmax_ - jmin_ +1 - else - kb = a%k ! Should this be jmax_ ?? - endif - - - sizeb = psb_sp_get_nnzeros(a) - call psb_sp_all(mb,kb,b,sizeb,info) - b%fida = 'COO' - b%descra = a%descra - nzb = 0 - do i=imin_, imax_, irbk - nrt = min(irbk,imax_-i+1) - ifst = i - ilst = ifst + nrt - 1 - call psb_sp_getrow(ifst,a,nzt,b%ia1,b%ia2,b%aspk,info,& - & lrw=ilst, append=.true.,nzin=nzb) - do j=nzb+1,nzb+nzt - if ((jmin_ <= b%ia2(j)).and.(b%ia2(j) <= jmax_)) then - nzb = nzb + 1 - b%aspk(nzb) = b%aspk(j) - b%ia1(nzb) = b%ia1(j) - b%ia2(nzb) = b%ia2(j) - end if - end do - - end do - b%infoa(psb_nnz_) = nzb - - if (rscale_) then - do i=1, nzb - b%ia1(i) = b%ia1(i) - imin_ + 1 - end do - end if - if (cscale_) then - do i=1, nzb - b%ia2(i) = b%ia2(i) - jmin_ + 1 - end do - end if - call psb_fixcoo(b,info) - call psb_sp_trim(b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dspclip - diff --git a/base/serial/psb_dspcnv.f90 b/base/serial/psb_dspcnv.f90 deleted file mode 100644 index 0753d2023..000000000 --- a/base/serial/psb_dspcnv.f90 +++ /dev/null @@ -1,572 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspcnv.f90 -! -! Subroutine: psb_dspcnv2 -! This subroutine converts the storage format of a matrix. -! -! Arguments: -! -! a - type(psb_spmat_type), input The input matrix to be converted. -! b - type(psb_spmat_type), output The assembled output matrix. -! info - integer. Return code -! afmt - character, optional The desired storage format -! -subroutine psb_dspcnv2(a, b,info,afmt,upd,dupl) - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dspcnv2 - implicit none - !....Parameters... - Type(psb_dspmat_type), intent(in) :: A - Type(psb_dspmat_type), intent(out) :: B - Integer, intent(out) :: info - Integer, intent(in), optional :: upd,dupl - character(len=*), optional, intent(in) :: afmt - - !...Locals... - real(psb_dpk_) :: d(1) - real(psb_dpk_), allocatable :: work(:) - type(psb_dspmat_type) :: temp_a - Integer :: nzr, ntry, ifc_, ia1_size,& - & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ - integer :: err_act - character :: check_,trans_,unitd_ - character(len=5) :: afmt_ - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - - name='psb_spcnv2' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ntry=0 - - ifc_ = 2 - - check_ = 'N' - trans_ = 'N' - unitd_ = 'U' - allocate(work(max(size(a%ia1),size(a%ia2))+a%m+1000),stat=info) - - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,b,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,b,info) - end if - if (present(afmt)) then - afmt_ = psb_toupper(afmt) - else - afmt_ = psb_fidef_ - end if - - upd_ = psb_sp_getifld(psb_upd_,b,info) - select case(upd_) - case(psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,b,info) - end select - - dupl_ = psb_sp_getifld(psb_dupl_,b,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,b,info) - end select - - ! ...matrix conversion... - b%m=a%m - b%k=a%k - b%fida=psb_toupper(afmt_) - size_req = psb_sp_get_nnzeros(a) - ! - n_row=b%m - n_col=b%k - call psb_cest(afmt_,n_row,n_col,size_req,& - & ia1_size, ia2_size, aspk_size, upd_,info) - b%fida=afmt_ - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_cest' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - if (.not.allocated(b%aspk).or.& - &.not.allocated(b%ia1).or.& - &.not.allocated(b%ia2).or.& - &.not.allocated(b%pl).or.& - &.not.allocated(b%pr)) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - else if ((size(b%aspk) < aspk_size) .or.& - &(size(b%ia1) < ia1_size) .or.& - &(size(b%ia2) < ia2_size) .or.& - &(size(b%pl) < b%m) .or.& - &(size(b%pr) < b%k )) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - endif - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - b%pl(:) = 0 - b%pr(:) = 0 - - b%descra = a%descra - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': size_req 1:',& - & size_req, trans_,upd_,dupl_,b%fida,b%descra - - select case (psb_toupper(a%fida)) - - case ('CSR') - - select case (psb_toupper(b%fida)) - - case ('CSR') - - call dcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - - if (info/=0) then - info=4010 - ch_err='dcrcr' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case ('JAD') - - !...converting to JAD - !...output matrix may not be big enough - do - - call dcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - endif - - ntry = ntry + 1 - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),' On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(debug_unit,*) trim(name),& - & ' Tried reallocating for DCRJAD for ',maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - call psb_cest(afmt_,n_row,n_col,nzr,& - & ia1_size, ia2_size, aspk_size, upd_,info) - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - if (info/=0) then - call psb_errpush(info,name) - goto 9999 - end if - - case ('COO') - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),' Calling CRCO ',a%descra - call dcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrco') - goto 9999 - end if - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - case ('COO','COI') - - select case (psb_toupper(b%fida)) - - case ('CSR') - - call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - case ('JAD') - - call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - temp_a%m = a%m - temp_a%k = a%k - temp_a%infoa=b%infoa - !...Dirty trick: converting to CSR and then to JAD - - call dcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, & - & size(temp_a%aspk), size(temp_a%ia1),& - & size(temp_a%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - do - call dcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, & - & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, & - & size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - end if - - ntry = ntry + 1 - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),' On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(debug_unit,*) trim(name),' Tried reallocating for DCRJAD for ',& - & maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_sp_reall(b,nzr,info,ifc=ifc_) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - case ('COO') - - call dcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcoco') - goto 9999 - end if - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - end select - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) then - call psb_sp_trim(b,info) - end if - - - call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dspcnv2 - - -! -! Subroutine: psb_dspcnv1 -! This subroutine converts in place the storage format of a matrix. -! -! Arguments: -! -! a - type(psb_spmat_type), inout The input matrix to be converted. -! info - integer. Return code -! afmt - character, optional The desired storage format -! -subroutine psb_dspcnv1(a, info, afmt, upd, dupl) - - use psb_spmat_type - use psb_regen_mod - use psb_serial_mod, psb_protect_name => psb_dspcnv1 - use psb_const_mod - use psi_mod - use psb_error_mod - use psb_string_mod - !use psb_penv_mod - - implicit none - - - !...Parameters.... - type(psb_dspmat_type), intent (inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: afmt - - integer :: int_err(5) - type(psb_dspmat_type) :: atemp - integer :: err_act - integer :: spstate - integer :: upd_, dupl_ - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - logical :: inplace - - info = 0 - int_err(1)=0 - name = 'psb_spcnv1' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,a,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,a,info) - end if - - upd_ = psb_sp_getifld(psb_upd_,a,info) - select case(upd_) - case(psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,a,info) - end select - - dupl_ = psb_sp_getifld(psb_dupl_,a,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,a,info) - end select - - - spstate = psb_sp_getifld(psb_state_,a,info) - if (info /= 0) then - goto 9999 - endif - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': Sparse matrix state:',& - & spstate,psb_spmat_bld_,psb_spmat_upd_ - if (spstate /= psb_spmat_upd_) then - ! Should we first figure out if we can do it in place? - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Update:',upd_,psb_upd_srch_,psb_upd_perm_ - inplace = .false. - if (upd_ == psb_upd_srch_) then - if (present(afmt)) then - select case (psb_toupper(a%fida)) - case('COO') - select case(psb_toupper(afmt)) - case('COO') - call psb_fixcoo(a,info) - inplace = .true. - case('CSR') - call psb_ipcoo2csr(a,info) - inplace = .true. - case('CSC') - call psb_ipcoo2csc(a,info) - inplace = .true. - end select - case('CSR') - select case(psb_toupper(afmt)) - case('COO') - call psb_ipcsr2coo(a,info) - inplace = .true. - end select - end select - end if - if (inplace) then - if (info == 0) call psb_sp_trim(a,info) - if (info /= 0) then - info=4010 - ch_err='inplace cnv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - call psb_erractionrestore(err_act) - return - end if - end if - - call psb_sp_clone(a,atemp,info) - if(info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_clone' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - ! convert to user requested format after the temp copy - end if - - ! Do the real conversion into the requested storage format - ! result is put in A - call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit, *) trim(name),& - & ': From SPCNV',info,' ',a%fida - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - call psb_sp_free(atemp,info) - - else if (spstate == psb_spmat_upd_) then - ! - ! Second case: we come from an update loop. - ! - select case(psb_toupper(a%fida)) - case('CSR') - call csr_regen(a,info) - case ('COO','COI') - call coo_regen(a,info) - case('JAD') - call jad_regen(a,info) - case default - info=136 - ch_err=a%fida - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (info /= psb_no_err_) then - info = 4010 - ch_err='xx_regen' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - else - - info = 600 - call psb_errpush(info,name) - goto 9999 - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ - - endif - - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dspcnv1 diff --git a/base/serial/psb_dspgetrow.f90 b/base/serial/psb_dspgetrow.f90 deleted file mode 100644 index 01338f547..000000000 --- a/base/serial/psb_dspgetrow.f90 +++ /dev/null @@ -1,130 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspgetrow.f90 -! Subroutine: psb_dspgetrow -! Gets one or more rows from a sparse matrix. -! Arguments: -! irw - integer, input The row to be extracted -! a - type(psb_dspmat_type),input The sparse matrix -! nz - integer, output The number of entries -! ia(:) - integer, allocatable, inout The output row indices -! ja(:) - integer, allocatable, inout The output col indices -! val(:) - real, allocatable,inout The coefficients -! info - integer, output Error code -! iren(:) - integer, input,optional Renumbering of indices -! lrw - integer, input,optional Extract rows irw:lrw, default lrw=irw -! append - logical, input,optional Should we append to already existing -! partial output? -! nzin - integer, input, optional If appending, how many entries were already -! occupied. -! -subroutine psb_dspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) - ! Output is always in COO format - use psb_spmat_type - use psb_const_mod - use psb_getrow_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dspgetrow - implicit none - - type(psb_dspmat_type), intent(in) :: a - integer, intent(in) :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: lrw, nzin - - logical :: append_ - integer :: nzin_, lrw_, irw_, err_act - character(len=20) :: name, ch_err - - name='psb_spgetrow' - info = 0 - - call psb_erractionsave(err_act) - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_=append - else - append_=.false. - endif - - - if ((append_).and.(present(nzin))) then - nzin_ = nzin - else - nzin_ = 0 - endif - - select case (psb_tolower(a%fida)) - case ('csr') - call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case ('coo') - call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case ('jad') - call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (info /= 0) goto 9999 -!!$ call psb_erractionrestore(err_act) - return - -9999 continue -!!$ call psb_erractionrestore(err_act) - call psb_erractionsave(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_dspgetrow - diff --git a/base/serial/psb_dspgtblk.f90 b/base/serial/psb_dspgtblk.f90 deleted file mode 100644 index de330b84c..000000000 --- a/base/serial/psb_dspgtblk.f90 +++ /dev/null @@ -1,114 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspgtblk.f90 -! Subroutine: psb_dspgtblk -! Gets one or more rows from a sparse matrix. -! Arguments: -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, * -!* * -!***************************************************************************** -subroutine psb_dspgtblk(irw,a,b,info,append,iren,lrw,srt) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dspgtblk - implicit none - - type(psb_dspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_dspmat_type), intent(inout) :: b - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - logical, intent(in), optional :: srt - - logical :: append_,srt_ - integer :: nz,nzb, lrw_, irw_ - character(len=20) :: name - - name='psb_spgtblk' - info = 0 - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_ = append - else - append_ = .false. - endif - - if (present(srt)) then - srt_ = srt - else - srt_ = .true. - endif - - - if (append_) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - b%m = 0 - b%k = 0 - b%descra = a%descra - endif - b%fida = 'COO' - - call psb_sp_getrow(irw,a,nz,b%ia1,b%ia2,b%aspk,info,iren=iren,& - & lrw=lrw_,append=append_,nzin=nzb) - if (info == 0) call psb_ensure_size(1,b%pl,info) - if (info == 0) call psb_ensure_size(1,b%pr,info) - if (info /= 0) return - b%pl = 0 - b%pr = 0 - b%infoa(psb_nnz_) = nzb+nz - b%m = b%m+lrw_-irw+1 - b%k = max(b%k,a%k) - if (srt_) call psb_fixcoo(b,info) - return - -end subroutine psb_dspgtblk - diff --git a/base/serial/psb_dspgtdiag.f90 b/base/serial/psb_dspgtdiag.f90 deleted file mode 100644 index 509a9b502..000000000 --- a/base/serial/psb_dspgtdiag.f90 +++ /dev/null @@ -1,123 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspgtdiag.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* * -!***************************************************************************** -subroutine psb_dspgtdiag(a,d,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_serial_mod, psb_protect_name => psb_dspgtdiag - implicit none - - type(psb_dspmat_type), intent(in) :: a - real(psb_dpk_), intent(inout) :: d(:) - integer, intent(out) :: info - - type(psb_dspmat_type) :: tmpa - integer :: i,j, err_act, ii, rng, irb, nrb - character(len=20) :: name, ch_err - - name='psb_dspgtdiag' - info = 0 - call psb_erractionsave(err_act) - - if (size(d) < min(a%k,a%m)) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - d(:) = 0.d0 - if (a%fida == 'CSR') then - - do i=1, min(a%m,a%k) - do j=a%ia2(i),a%ia2(i+1)-1 - if (a%ia1(j) == i) then - d(i) = a%aspk(j) - end if - end do - end do - - else if (a%fida == 'COO') then - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - if ((j==a%ia2(i)).and.(j <= min(a%k,a%m)) .and.(j>0)) then - d(j) = a%aspk(i) - endif - enddo - - else if (a%fida == 'JAD') then - - rng=min(a%m,a%k) - nrb=16 - do i=1, rng, nrb - irb=min(i+nrb-1,rng) - call psb_sp_getblk(i,a,tmpa,info,lrw=irb) - if(info /= 0) then - info=4010 - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do ii=1,tmpa%infoa(psb_nnz_) - j=tmpa%ia1(ii) - if ((j==tmpa%ia2(ii)).and.(j <= rng) .and.(j>0)) then - d(j) = tmpa%aspk(ii) - endif - enddo - - end do - - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dspgtdiag - diff --git a/base/serial/psb_dspscal.f90 b/base/serial/psb_dspscal.f90 deleted file mode 100644 index 8d94c33e8..000000000 --- a/base/serial/psb_dspscal.f90 +++ /dev/null @@ -1,158 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspscal.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* * -!***************************************************************************** -subroutine psb_dspscal(a,d,info) - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - real(psb_dpk_), intent(in) :: d(:) - - integer :: i,j,err_act - character(len=20) :: name, ch_err - - name='psb_dspscal' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_toupper(a%fida(1:3))) - case ('CSR') - - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - a%aspk(j) = a%aspk(j) * d(i) - end do - end do - - case ('COO') - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - a%aspk(i) = a%aspk(i) * d(j) - enddo - - case ('JAD') - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dspscal -subroutine psb_dspscals(a,d,info) - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - real(psb_dpk_), intent(in) :: d - - integer :: i,j,err_act - character(len=20) :: name, ch_err - - name='psb_dspscal' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_toupper(a%fida(1:3))) - case ('CSR') - - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - a%aspk(j) = a%aspk(j) * d - end do - end do - - case ('COO') - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - a%aspk(i) = a%aspk(i) * d - enddo - - case ('JAD') - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_dspscals - diff --git a/base/serial/psb_dspsetbld.f90 b/base/serial/psb_dspsetbld.f90 deleted file mode 100644 index 153a208dd..000000000 --- a/base/serial/psb_dspsetbld.f90 +++ /dev/null @@ -1,152 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspgtblk.f90 -! Subroutine: psb_dspgtblk -! Gets one or more rows from a sparse matrix. -! Arguments: -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, * -!* * -!***************************************************************************** -subroutine psb_dspsetbld1(a,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dspsetbld1 - - implicit none - - type(psb_dspmat_type), intent(inout) :: a - integer, intent(out) :: info - - logical :: append_,srt_ - integer :: i,j, err_act - character(len=20) :: name - - name='psb_sp_setbld' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_sp_getifld(psb_state_,a,info)) - case (psb_spmat_asb_,psb_spmat_upd_) - call psb_spcnv(a,info,afmt='COO') - if (info == 0) call psb_sp_setifld(psb_spmat_bld_,psb_state_,a,info) - case (psb_spmat_bld_) - ! do nothing - - case default - info=591 - call psb_errpush(info,name) - goto 9999 - end select - - - if (info /= 0) then - call psb_errpush(4010,name,a_err='Internal call') - goto 9999 - end if - - call psb_erractionrestore(err_act) - - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_dspsetbld1 -subroutine psb_dspsetbld2(a,b,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dspsetbld2 - - implicit none - - type(psb_dspmat_type), intent(in) :: a - type(psb_dspmat_type), intent(out) :: b - integer, intent(out) :: info - - logical :: append_,srt_ - integer :: i,j, err_act - character(len=20) :: name - - name='psb_sp_setbld' - info = 0 - call psb_erractionsave(err_act) - - - select case(psb_sp_getifld(psb_state_,a,info)) - case (psb_spmat_asb_,psb_spmat_upd_) - call psb_spcnv(a,b,info,afmt='COO') - if (info == 0) call psb_sp_setifld(psb_spmat_bld_,psb_state_,b,info) - - case (psb_spmat_bld_) - call psb_sp_clone(a,b,info) - - case default - info=591 - call psb_errpush(info,name) - goto 9999 - end select - - if (info /= 0) then - call psb_errpush(4010,name,a_err='Internal call') - goto 9999 - end if - - call psb_erractionrestore(err_act) - - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_dspsetbld2 - diff --git a/base/serial/psb_dspshift.f90 b/base/serial/psb_dspshift.f90 deleted file mode 100644 index bec05510f..000000000 --- a/base/serial/psb_dspshift.f90 +++ /dev/null @@ -1,91 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dspgtblk.f90 -! Subroutine: psb_dspgtblk -! Gets one or more rows from a sparse matrix. -! Arguments: -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, * -!* * -!***************************************************************************** -subroutine psb_dspshift(alpha,a,beta,b,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dspshift - - implicit none - - type(psb_dspmat_type), intent(in) :: a - type(psb_dspmat_type), intent(out) :: b - real(psb_dpk_), intent(in) :: alpha, beta - integer, intent(out) :: info - - logical :: append_,srt_ - integer :: i,j, err_act - character(len=20) :: name - - name='psb_sp_shift' - info = 0 - call psb_erractionsave(err_act) - - call psb_sp_setbld(a,b,info) - if (info == 0) call psb_sp_scal(b,alpha,info) - do i=1,min(b%m,b%k) - if (info == 0) call psb_coins(1,(/i/),(/i/),(/beta/),b,1,1,b%m,b%k,info) - end do - if (info == 0) call psb_spcnv(b,info,afmt=a%fida,dupl=psb_dupl_add_) - - if (info /= 0) then - call psb_errpush(4010,name,a_err='Internal call') - goto 9999 - end if - - call psb_erractionrestore(err_act) - - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_dspshift - diff --git a/base/serial/psb_dtransp.f90 b/base/serial/psb_dtransp.f90 deleted file mode 100644 index 436291d2f..000000000 --- a/base/serial/psb_dtransp.f90 +++ /dev/null @@ -1,121 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_dtransp.f90 -! Subroutine: -! Arguments: - -subroutine psb_dtransp(a,b,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dtransp - implicit none - - type(psb_dspmat_type), intent(in) :: a - type(psb_dspmat_type), intent(out) :: b - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer ::c_, info - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_nullify_sp(b) - - call psb_spcnv(a,b,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(b%ia1,itmp,info) - call psb_move_alloc(b%ia2,b%ia1,info) - call psb_move_alloc(itmp,b%ia2,info) - - b%m = a%k - b%k = a%m - call psb_spcnv(b,info,afmt=fmt_) - - return -end subroutine psb_dtransp - -subroutine psb_dtransp1(a,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_dtransp1 - implicit none - - type(psb_dspmat_type), intent(inout) :: a - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer ::c_, info - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_spcnv(a,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(a%ia1,itmp,info) - call psb_move_alloc(a%ia2,a%ia1,info) - call psb_move_alloc(itmp,a%ia2,info) - - call psb_spcnv(a,info,afmt=fmt_) - - return -end subroutine psb_dtransp1 diff --git a/base/serial/psb_getifield.f90 b/base/serial/psb_getifield.f90 deleted file mode 100644 index 604a036be..000000000 --- a/base/serial/psb_getifield.f90 +++ /dev/null @@ -1,45 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_getifield(val,field,info,isize,ierr) - integer :: val,field,isize,ierr - integer :: info(*) - - ierr = 0 - val = -1 - if ((field < 1).or.(field > isize)) then - ierr = -1 - return - endif - - val = info(field) - return -end subroutine psb_getifield diff --git a/base/serial/psb_getrow_mod.f90 b/base/serial/psb_getrow_mod.f90 deleted file mode 100644 index 4fd221490..000000000 --- a/base/serial/psb_getrow_mod.f90 +++ /dev/null @@ -1,1752 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -module psb_getrow_mod - - interface csr_getrow - module procedure csr_cspgtrow, csr_zspgtrow - end interface - interface coo_getrow - module procedure coo_cspgtrow, coo_zspgtrow - end interface - interface jad_getrow - module procedure jad_cspgtrow, jad_zspgtrow - end interface - -contains - -!!$ subroutine csr_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) -!!$ -!!$ use psb_sort_mod -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(in) :: a -!!$ integer :: irw -!!$ integer, intent(out) :: nz -!!$ integer, allocatable, intent(inout) :: ia(:), ja(:) -!!$ real(psb_spk_), allocatable, intent(inout) :: val(:) -!!$ integer :: nzin -!!$ logical, intent(in) :: append -!!$ integer :: lrw,info -!!$ integer, optional :: iren(:) -!!$ -!!$ integer :: idx,i,j, k, nr, row_idx, nzin_ -!!$ integer, allocatable :: indices(:) -!!$ -!!$ if (append) then -!!$ nzin_ = nzin -!!$ else -!!$ nzin_ = 0 -!!$ endif -!!$ -!!$ if (a%pl(1) /= 0) then -!!$ -!!$ nr = lrw - irw + 1 -!!$ allocate(indices(nr)) -!!$ nz = 0 -!!$ do i=1,nr -!!$ indices(i)=a%pl(irw+i-1) -!!$ nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i)) -!!$ end do -!!$ -!!$ call psb_ensure_size(nzin_+nz,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info) -!!$ if (info /= 0) return -!!$ -!!$ k=0 -!!$ if(present(iren)) then -!!$ do i=1,nr -!!$ row_idx=indices(i) -!!$ do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 -!!$ k = k + 1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = iren(row_idx) -!!$ ja(nzin_+k) = iren(a%ia1(j)) -!!$ end do -!!$ end do -!!$ else -!!$ do i=1,nr -!!$ row_idx=indices(i) -!!$ do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 -!!$ k = k + 1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = row_idx -!!$ ja(nzin_+k) = a%ia1(j) -!!$ end do -!!$ end do -!!$ end if -!!$ -!!$ else -!!$ -!!$ idx = irw -!!$ -!!$ if (idx<0) then -!!$ write(0,*) ' spgtrow Error : idx no good ',idx -!!$ info = 2 -!!$ return -!!$ end if -!!$ nr = lrw - irw + 1 -!!$ nz = a%ia2(idx+nr) - a%ia2(idx) -!!$ -!!$ call psb_ensure_size(nzin_+nz,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info) -!!$ if (info /= 0) return -!!$ -!!$ -!!$ if (present(iren)) then -!!$ k=0 -!!$ do i=irw,lrw -!!$ do j=a%ia2(i),a%ia2(i+1)-1 -!!$ k = k + 1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = iren(i) -!!$ ja(nzin_+k) = iren(a%ia1(j)) -!!$ end do -!!$ enddo -!!$ else -!!$ k=0 -!!$ -!!$ do i=irw,lrw -!!$ do j=a%ia2(i),a%ia2(i+1)-1 -!!$ k = k + 1 -!!$ ia(nzin_+k) = i -!!$ ja(nzin_+k) = a%ia1(j) -!!$ val(nzin_+k) = a%aspk(j) -!!$ end do -!!$ enddo -!!$ end if -!!$! !$ if (nz /= k) then -!!$! !$ write(0,*) 'csr getrow Size mismatch ',nz,k -!!$! !$ endif -!!$ if (a%pr(1) /= 0) then -!!$ write(0,*) 'Feeling lazy today, Right Permutation will have to wait' -!!$ endif -!!$ -!!$ endif -!!$ -!!$ end subroutine csr_sspgtrow -!!$ -!!$ subroutine coo_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) -!!$ -!!$ use psb_sort_mod -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(in) :: a -!!$ integer :: irw -!!$ integer, intent(out) :: nz -!!$ integer, allocatable, intent(inout) :: ia(:), ja(:) -!!$ real(psb_spk_), allocatable, intent(inout) :: val(:) -!!$ integer :: nzin -!!$ logical, intent(in) :: append -!!$ integer :: lrw,info -!!$ integer, optional :: iren(:) -!!$ integer :: nzin_, nza, idx,ip,jp,i,k, nzt -!!$ integer :: debug_level, debug_unit -!!$ character(len=20) :: name='coo_sspgtrow' -!!$ -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ nza = a%infoa(psb_nnz_) -!!$ if (a%pl(1) /= 0) then -!!$ write(debug_unit,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!' -!!$ idx = -1 -!!$ else -!!$ idx = irw -!!$ endif -!!$ if (idx<0) then -!!$ write(debug_unit,*) ' spgtrow Error : idx no good ',idx -!!$ info = 2 -!!$ return -!!$ end if -!!$ -!!$ if (append) then -!!$ nzin_ = nzin -!!$ else -!!$ nzin_ = 0 -!!$ endif -!!$ -!!$ if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then -!!$ ! In this case we can do a binary search. -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name), ': srtdcoo ' -!!$ do -!!$ ip = psb_ibsrch(irw,nza,a%ia1) -!!$ if (ip /= -1) exit -!!$ irw = irw + 1 -!!$ if (irw > lrw) then -!!$ write(debug_unit,*) trim(name),& -!!$ & 'Warning : did not find any rows. Is this an error? ',& -!!$ & irw,lrw,idx -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ if (ip /= -1) then -!!$ ! expand [ip,jp] to contain all row entries. -!!$ do -!!$ if (ip < 2) exit -!!$ if (a%ia1(ip-1) == irw) then -!!$ ip = ip -1 -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ end if -!!$ -!!$ do -!!$ jp = psb_ibsrch(lrw,nza,a%ia1) -!!$ if (jp /= -1) exit -!!$ lrw = lrw - 1 -!!$ if (irw > lrw) then -!!$ write(debug_unit,*) trim(name),& -!!$ & 'Warning : did not find any rows. Is this an error?' -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ if (jp /= -1) then -!!$ ! expand [ip,jp] to contain all row entries. -!!$ do -!!$ if (jp == nza) exit -!!$ if (a%ia1(jp+1) == lrw) then -!!$ jp = jp + 1 -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ end if -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza -!!$ if ((ip /= -1) .and.(jp /= -1)) then -!!$ ! Now do the copy. -!!$ nz = jp - ip +1 -!!$ -!!$ call psb_ensure_size(nzin_+nz,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info) -!!$ if (info /= 0) return -!!$ -!!$ if (present(iren)) then -!!$ do i=ip,jp -!!$ nzin_ = nzin_ + 1 -!!$ val(nzin_) = a%aspk(i) -!!$ ia(nzin_) = iren(a%ia1(i)) -!!$ ja(nzin_) = iren(a%ia2(i)) -!!$ enddo -!!$ else -!!$ do i=ip,jp -!!$ nzin_ = nzin_ + 1 -!!$ val(nzin_) = a%aspk(i) -!!$ ia(nzin_) = a%ia1(i) -!!$ ja(nzin_) = a%ia2(i) -!!$ enddo -!!$ end if -!!$ else -!!$ nz = 0 -!!$ end if -!!$ -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),': unsorted ' -!!$ -!!$ nzt = (nza*(lrw-irw+1))/max(a%m,1) -!!$ call psb_ensure_size(nzin_+nzt,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info) -!!$ if (info /= 0) return -!!$ -!!$ if (present(iren)) then -!!$ k = 0 -!!$ do i=1, a%infoa(psb_nnz_) -!!$ if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then -!!$ k = k + 1 -!!$ if (k > nzt) then -!!$ nzt = k -!!$ call psb_ensure_size(nzin_+nzt,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info) -!!$ if (info /= 0) return -!!$ end if -!!$ val(nzin_+k) = a%aspk(i) -!!$ ia(nzin_+k) = iren(a%ia1(i)) -!!$ ja(nzin_+k) = iren(a%ia2(i)) -!!$ endif -!!$ enddo -!!$ else -!!$ k = 0 -!!$ do i=1,a%infoa(psb_nnz_) -!!$ if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then -!!$ k = k + 1 -!!$ if (k > nzt) then -!!$ nzt = k -!!$ call psb_ensure_size(nzin_+nzt,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info) -!!$ if (info /= 0) return -!!$ -!!$ end if -!!$ val(nzin_+k) = a%aspk(i) -!!$ ia(nzin_+k) = (a%ia1(i)) -!!$ ja(nzin_+k) = (a%ia2(i)) -!!$ endif -!!$ enddo -!!$ nzin_=nzin_+k -!!$ end if -!!$ nz = k -!!$ end if -!!$ -!!$ end subroutine coo_sspgtrow -!!$ -!!$ -!!$ subroutine jad_sspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) -!!$ -!!$ use psb_sort_mod -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(in), target :: a -!!$ integer :: irw -!!$ integer, intent(out) :: nz -!!$ integer, allocatable, intent(inout) :: ia(:), ja(:) -!!$ real(psb_spk_), allocatable, intent(inout) :: val(:) -!!$ integer :: nzin -!!$ logical, intent(in) :: append -!!$ integer, optional :: iren(:) -!!$ integer :: lrw,info -!!$ -!!$ integer, pointer :: ia1(:), ia2(:), ia3(:),& -!!$ & ja_(:), ka_(:), indices(:), blks(:) -!!$ integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng, nzin_,& -!!$ & i,j,k,nr -!!$ -!!$ -!!$ png = a%ia2(1) ! points to the number of blocks -!!$ pia = a%ia2(2) ! points to the beginning of ia(3,png) -!!$ pja = a%ia2(3) ! points to the beginning of ja(:) -!!$ -!!$ ng = a%ia2(png) ! the number of blocks -!!$ ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk -!!$ ka_ => a%ia1(:) ! the array containing the column indices -!!$ ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index of each block -!!$ ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. in ja to the first jad column -!!$ ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. in ja to the first csr column -!!$ -!!$ if (append) then -!!$ nzin_ = nzin -!!$ else -!!$ nzin_ = 0 -!!$ endif -!!$ -!!$ if (a%pl(1) /= 0) then -!!$ -!!$ nr = lrw - irw + 1 -!!$ allocate(indices(nr),blks(nr)) -!!$ nz = 0 -!!$ -!!$ do i=1,nr -!!$ indices(i)=a%pl(irw+i-1) -!!$ j=0 -!!$ blkfnd: do -!!$ j=j+1 -!!$ if(ia1(j) == indices(i)) then -!!$ blks(i)=j -!!$ nz=nz+ia3(j)-ia2(j) -!!$ ipx = ia1(j) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j)+rb -!!$ nz = nz+ja_(row+1)-ja_(row) -!!$ exit blkfnd -!!$ else if(ia1(j) > indices(i)) then -!!$ blks(i)=j-1 -!!$ nz=nz+ia3(j-1)-ia2(j-1) -!!$ ipx = ia1(j-1) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j-1)+rb -!!$ nz = nz+ja_(row+1)-ja_(row) -!!$ exit blkfnd -!!$ end if -!!$ end do blkfnd -!!$ end do -!!$ -!!$ -!!$ call psb_ensure_size(nzin_+nz,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info) -!!$ if (info /= 0) return -!!$ -!!$ k=0 -!!$ ! cycle over rows -!!$ do i=1,nr -!!$ -!!$ ! find which block the row belongs to -!!$ blk = blks(i) -!!$ -!!$ ! extract first part of the row from the jad block -!!$ ipx = ia1(blk) ! the first row index of the block -!!$ k_pt= ia2(blk) ! the pointer to the beginning of a column in ja -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block -!!$ -!!$ if(present(iren))then -!!$ do col = ia2(blk), ia3(blk)-1 -!!$ k=k+1 -!!$ val(nzin_+k) = a%aspk(ja_(col)+rb) -!!$ ia(nzin_+k) = iren(irw+i-1) -!!$ ja(nzin_+k) = iren(ka_(ja_(col)+rb)) -!!$ end do -!!$ else -!!$ do col = ia2(blk), ia3(blk)-1 -!!$ k=k+1 -!!$ val(nzin_+k) = a%aspk(ja_(col)+rb) -!!$ ia(nzin_+k) = irw+i-1 -!!$ ja(nzin_+k) = ka_(ja_(col)+rb) -!!$ end do -!!$ end if -!!$ ! extract second part of the row from the csr tail -!!$ row=ia3(blk)+rb -!!$ if(present(iren))then -!!$ do j=ja_(row), ja_(row+1)-1 -!!$ k=k+1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = iren(irw+i-1) -!!$ ja(nzin_+k) = iren(ka_(j)) -!!$ end do -!!$ else -!!$ do j=ja_(row), ja_(row+1)-1 -!!$ k=k+1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = irw+i-1 -!!$ ja(nzin_+k) = ka_(j) -!!$ end do -!!$ end if -!!$ end do -!!$ -!!$ else -!!$ ! There might be some problems -!!$ info=134 -!!$ end if -!!$ -!!$ end subroutine jad_sspgtrow - - -!!$ subroutine csr_dspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) -!!$ -!!$ use psb_sort_mod -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(in) :: a -!!$ integer :: irw -!!$ integer, intent(out) :: nz -!!$ integer, allocatable, intent(inout) :: ia(:), ja(:) -!!$ real(psb_dpk_), allocatable, intent(inout) :: val(:) -!!$ integer :: nzin -!!$ logical, intent(in) :: append -!!$ integer :: lrw,info -!!$ integer, optional :: iren(:) -!!$ -!!$ integer :: idx,i,j, k, nr, row_idx, nzin_ -!!$ integer, allocatable :: indices(:) -!!$ -!!$ if (append) then -!!$ nzin_ = nzin -!!$ else -!!$ nzin_ = 0 -!!$ endif -!!$ -!!$ if (a%pl(1) /= 0) then -!!$ -!!$ nr = lrw - irw + 1 -!!$ allocate(indices(nr)) -!!$ nz = 0 -!!$ do i=1,nr -!!$ indices(i)=a%pl(irw+i-1) -!!$ nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i)) -!!$ end do -!!$ -!!$ call psb_ensure_size(nzin_+nz,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info) -!!$ if (info /= 0) return -!!$ -!!$ k=0 -!!$ if(present(iren)) then -!!$ do i=1,nr -!!$ row_idx=indices(i) -!!$ do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 -!!$ k = k + 1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = iren(row_idx) -!!$ ja(nzin_+k) = iren(a%ia1(j)) -!!$ end do -!!$ end do -!!$ else -!!$ do i=1,nr -!!$ row_idx=indices(i) -!!$ do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 -!!$ k = k + 1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = row_idx -!!$ ja(nzin_+k) = a%ia1(j) -!!$ end do -!!$ end do -!!$ end if -!!$ -!!$ else -!!$ -!!$ idx = irw -!!$ -!!$ if (idx<0) then -!!$ write(0,*) ' spgtrow Error : idx no good ',idx -!!$ info = 2 -!!$ return -!!$ end if -!!$ nr = lrw - irw + 1 -!!$ nz = a%ia2(idx+nr) - a%ia2(idx) -!!$ -!!$ call psb_ensure_size(nzin_+nz,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info) -!!$ if (info /= 0) return -!!$ -!!$ -!!$ if (present(iren)) then -!!$ k=0 -!!$ do i=irw,lrw -!!$ do j=a%ia2(i),a%ia2(i+1)-1 -!!$ k = k + 1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = iren(i) -!!$ ja(nzin_+k) = iren(a%ia1(j)) -!!$ end do -!!$ enddo -!!$ else -!!$ k=0 -!!$ -!!$ do i=irw,lrw -!!$ do j=a%ia2(i),a%ia2(i+1)-1 -!!$ k = k + 1 -!!$ ia(nzin_+k) = i -!!$ ja(nzin_+k) = a%ia1(j) -!!$ val(nzin_+k) = a%aspk(j) -!!$ end do -!!$ enddo -!!$ end if -! !$ if (nz /= k) then -! !$ write(0,*) 'csr getrow Size mismatch ',nz,k -! !$ endif -!!$ if (a%pr(1) /= 0) then -!!$ write(0,*) 'Feeling lazy today, Right Permutation will have to wait' -!!$ endif -!!$ -!!$ endif -!!$ -!!$ end subroutine csr_dspgtrow - -!!$ subroutine coo_dspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) -!!$ -!!$ use psb_sort_mod -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(in) :: a -!!$ integer :: irw -!!$ integer, intent(out) :: nz -!!$ integer, allocatable, intent(inout) :: ia(:), ja(:) -!!$ real(psb_dpk_), allocatable, intent(inout) :: val(:) -!!$ integer :: nzin -!!$ logical, intent(in) :: append -!!$ integer :: lrw,info -!!$ integer, optional :: iren(:) -!!$ integer :: nzin_, nza, idx,ip,jp,i,k, nzt -!!$ integer :: debug_level, debug_unit -!!$ character(len=20) :: name='coo_dspgtrow' -!!$ -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ nza = a%infoa(psb_nnz_) -!!$ if (a%pl(1) /= 0) then -!!$ write(debug_unit,*) 'Fatal error in SPGTROW: do not feed a permuted mat so far!' -!!$ idx = -1 -!!$ else -!!$ idx = irw -!!$ endif -!!$ if (idx<0) then -!!$ write(debug_unit,*) ' spgtrow Error : idx no good ',idx -!!$ info = 2 -!!$ return -!!$ end if -!!$ -!!$ if (append) then -!!$ nzin_ = nzin -!!$ else -!!$ nzin_ = 0 -!!$ endif -!!$ -!!$ if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then -!!$ ! In this case we can do a binary search. -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name), ': srtdcoo ' -!!$ do -!!$ ip = psb_ibsrch(irw,nza,a%ia1) -!!$ if (ip /= -1) exit -!!$ irw = irw + 1 -!!$ if (irw > lrw) then -!!$ write(debug_unit,*) trim(name),& -!!$ & 'Warning : did not find any rows. Is this an error? ',& -!!$ & irw,lrw,idx -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ if (ip /= -1) then -!!$ ! expand [ip,jp] to contain all row entries. -!!$ do -!!$ if (ip < 2) exit -!!$ if (a%ia1(ip-1) == irw) then -!!$ ip = ip -1 -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ end if -!!$ -!!$ do -!!$ jp = psb_ibsrch(lrw,nza,a%ia1) -!!$ if (jp /= -1) exit -!!$ lrw = lrw - 1 -!!$ if (irw > lrw) then -!!$ write(debug_unit,*) trim(name),& -!!$ & 'Warning : did not find any rows. Is this an error?' -!!$ exit -!!$ end if -!!$ end do -!!$ -!!$ if (jp /= -1) then -!!$ ! expand [ip,jp] to contain all row entries. -!!$ do -!!$ if (jp == nza) exit -!!$ if (a%ia1(jp+1) == lrw) then -!!$ jp = jp + 1 -!!$ else -!!$ exit -!!$ end if -!!$ end do -!!$ end if -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza -!!$ if ((ip /= -1) .and.(jp /= -1)) then -!!$ ! Now do the copy. -!!$ nz = jp - ip +1 -!!$ -!!$ call psb_ensure_size(nzin_+nz,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info) -!!$ if (info /= 0) return -!!$ -!!$ if (present(iren)) then -!!$ do i=ip,jp -!!$ nzin_ = nzin_ + 1 -!!$ val(nzin_) = a%aspk(i) -!!$ ia(nzin_) = iren(a%ia1(i)) -!!$ ja(nzin_) = iren(a%ia2(i)) -!!$ enddo -!!$ else -!!$ do i=ip,jp -!!$ nzin_ = nzin_ + 1 -!!$ val(nzin_) = a%aspk(i) -!!$ ia(nzin_) = a%ia1(i) -!!$ ja(nzin_) = a%ia2(i) -!!$ enddo -!!$ end if -!!$ else -!!$ nz = 0 -!!$ end if -!!$ -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),': unsorted ' -!!$ -!!$ nzt = (nza*(lrw-irw+1))/max(a%m,1) -!!$ call psb_ensure_size(nzin_+nzt,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info) -!!$ if (info /= 0) return -!!$ -!!$ if (present(iren)) then -!!$ k = 0 -!!$ do i=1, a%infoa(psb_nnz_) -!!$ if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then -!!$ k = k + 1 -!!$ if (k > nzt) then -!!$ nzt = k -!!$ call psb_ensure_size(nzin_+nzt,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info) -!!$ if (info /= 0) return -!!$ end if -!!$ val(nzin_+k) = a%aspk(i) -!!$ ia(nzin_+k) = iren(a%ia1(i)) -!!$ ja(nzin_+k) = iren(a%ia2(i)) -!!$ endif -!!$ enddo -!!$ else -!!$ k = 0 -!!$ do i=1,a%infoa(psb_nnz_) -!!$ if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then -!!$ k = k + 1 -!!$ if (k > nzt) then -!!$ nzt = k -!!$ call psb_ensure_size(nzin_+nzt,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nzt,val,info) -!!$ if (info /= 0) return -!!$ -!!$ end if -!!$ val(nzin_+k) = a%aspk(i) -!!$ ia(nzin_+k) = (a%ia1(i)) -!!$ ja(nzin_+k) = (a%ia2(i)) -!!$ endif -!!$ enddo -!!$ nzin_=nzin_+k -!!$ end if -!!$ nz = k -!!$ end if -!!$ -!!$ end subroutine coo_dspgtrow -!!$ -!!$ -!!$ subroutine jad_dspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) -!!$ -!!$ use psb_sort_mod -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(in), target :: a -!!$ integer :: irw -!!$ integer, intent(out) :: nz -!!$ integer, allocatable, intent(inout) :: ia(:), ja(:) -!!$ real(psb_dpk_), allocatable, intent(inout) :: val(:) -!!$ integer :: nzin -!!$ logical, intent(in) :: append -!!$ integer, optional :: iren(:) -!!$ integer :: lrw,info -!!$ -!!$ integer, pointer :: ia1(:), ia2(:), ia3(:),& -!!$ & ja_(:), ka_(:), indices(:), blks(:) -!!$ integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng, nzin_,& -!!$ & i,j,k,nr -!!$ -!!$ -!!$ png = a%ia2(1) ! points to the number of blocks -!!$ pia = a%ia2(2) ! points to the beginning of ia(3,png) -!!$ pja = a%ia2(3) ! points to the beginning of ja(:) -!!$ -!!$ ng = a%ia2(png) ! the number of blocks -!!$ ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk -!!$ ka_ => a%ia1(:) ! the array containing the column indices -!!$ ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index of each block -!!$ ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. in ja to the first jad column -!!$ ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. in ja to the first csr column -!!$ -!!$ if (append) then -!!$ nzin_ = nzin -!!$ else -!!$ nzin_ = 0 -!!$ endif -!!$ -!!$ if (a%pl(1) /= 0) then -!!$ -!!$ nr = lrw - irw + 1 -!!$ allocate(indices(nr),blks(nr)) -!!$ nz = 0 -!!$ -!!$ do i=1,nr -!!$ indices(i)=a%pl(irw+i-1) -!!$ j=0 -!!$ blkfnd: do -!!$ j=j+1 -!!$ if(ia1(j) == indices(i)) then -!!$ blks(i)=j -!!$ nz=nz+ia3(j)-ia2(j) -!!$ ipx = ia1(j) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j)+rb -!!$ nz = nz+ja_(row+1)-ja_(row) -!!$ exit blkfnd -!!$ else if(ia1(j) > indices(i)) then -!!$ blks(i)=j-1 -!!$ nz=nz+ia3(j-1)-ia2(j-1) -!!$ ipx = ia1(j-1) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j-1)+rb -!!$ nz = nz+ja_(row+1)-ja_(row) -!!$ exit blkfnd -!!$ end if -!!$ end do blkfnd -!!$ end do -!!$ -!!$ -!!$ call psb_ensure_size(nzin_+nz,ia,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,ja,info) -!!$ if (info==0) call psb_ensure_size(nzin_+nz,val,info) -!!$ if (info /= 0) return -!!$ -!!$ k=0 -!!$ ! cycle over rows -!!$ do i=1,nr -!!$ -!!$ ! find which block the row belongs to -!!$ blk = blks(i) -!!$ -!!$ ! extract first part of the row from the jad block -!!$ ipx = ia1(blk) ! the first row index of the block -!!$ k_pt= ia2(blk) ! the pointer to the beginning of a column in ja -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block -!!$ -!!$ if(present(iren))then -!!$ do col = ia2(blk), ia3(blk)-1 -!!$ k=k+1 -!!$ val(nzin_+k) = a%aspk(ja_(col)+rb) -!!$ ia(nzin_+k) = iren(irw+i-1) -!!$ ja(nzin_+k) = iren(ka_(ja_(col)+rb)) -!!$ end do -!!$ else -!!$ do col = ia2(blk), ia3(blk)-1 -!!$ k=k+1 -!!$ val(nzin_+k) = a%aspk(ja_(col)+rb) -!!$ ia(nzin_+k) = irw+i-1 -!!$ ja(nzin_+k) = ka_(ja_(col)+rb) -!!$ end do -!!$ end if -!!$ ! extract second part of the row from the csr tail -!!$ row=ia3(blk)+rb -!!$ if(present(iren))then -!!$ do j=ja_(row), ja_(row+1)-1 -!!$ k=k+1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = iren(irw+i-1) -!!$ ja(nzin_+k) = iren(ka_(j)) -!!$ end do -!!$ else -!!$ do j=ja_(row), ja_(row+1)-1 -!!$ k=k+1 -!!$ val(nzin_+k) = a%aspk(j) -!!$ ia(nzin_+k) = irw+i-1 -!!$ ja(nzin_+k) = ka_(j) -!!$ end do -!!$ end if -!!$ end do -!!$ -!!$ else -!!$ ! There might be some problems -!!$ info=134 -!!$ end if -!!$ -!!$ end subroutine jad_dspgtrow - - - subroutine csr_cspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) - - use psb_sort_mod - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_cspmat_type), intent(in) :: a - integer :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer :: nzin - logical, intent(in) :: append - integer :: lrw,info - integer, optional :: iren(:) - - integer :: idx,i,j, k, nr, row_idx, nzin_ - integer, allocatable :: indices(:) - integer :: debug_level, debug_unit - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (append) then - nzin_ = nzin - else - nzin_ = 0 - endif - - if (a%pl(1) /= 0) then - - nr = lrw - irw + 1 - allocate(indices(nr)) - nz = 0 - do i=1,nr - indices(i)=a%pl(irw+i-1) - nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i)) - end do - - call psb_ensure_size(nzin_+nz,ia,info) - if (info==0) call psb_ensure_size(nzin_+nz,ja,info) - if (info==0) call psb_ensure_size(nzin_+nz,val,info) - if (info /= 0) return - - k=0 - if(present(iren)) then - do i=1,nr - row_idx=indices(i) - do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 - k = k + 1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = iren(row_idx) - ja(nzin_+k) = iren(a%ia1(j)) - end do - end do - else - do i=1,nr - row_idx=indices(i) - do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 - k = k + 1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = row_idx - ja(nzin_+k) = a%ia1(j) - end do - end do - end if - - else - idx = irw - - if (idx<0) then - write(0,*) ' spgtrow Error : idx no good ',idx - return - end if - nr = lrw - irw + 1 - nz = a%ia2(idx+nr) - a%ia2(idx) - - call psb_ensure_size(nzin_+nz,ia,info) - if (info==0) call psb_ensure_size(nzin_+nz,ja,info) - if (info==0) call psb_ensure_size(nzin_+nz,val,info) - if (info /= 0) return - - - if (present(iren)) then - k=0 - do i=irw,lrw - do j=a%ia2(i),a%ia2(i+1)-1 - k = k + 1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = iren(i) - ja(nzin_+k) = iren(a%ia1(j)) - end do - enddo - else - k=0 - - do i=irw,lrw - do j=a%ia2(i),a%ia2(i+1)-1 - k = k + 1 - ia(nzin_+k) = i - ja(nzin_+k) = a%ia1(j) - val(nzin_+k) = a%aspk(j) - end do - enddo - end if - if (a%pr(1) /= 0) then - write(debug_unit,*)& - & 'Feeling lazy today, Right Permutation will have to wait' - endif - - endif - - end subroutine csr_cspgtrow - - - subroutine coo_cspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) - - use psb_sort_mod - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_cspmat_type), intent(in) :: a - integer :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer :: nzin - logical, intent(in) :: append - integer :: lrw,info - integer, optional :: iren(:) - integer :: nzin_, nza, idx,ip,jp,i,k, nzt - integer :: debug_level, debug_unit - character(len=20) :: name='coo_zspgtrow' - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - nza = a%infoa(psb_nnz_) - if (a%pl(1) /= 0) then - write(debug_unit,*) trim(name),& - & 'Fatal error: do not feed a permuted mat so far!' - idx = -1 - else - idx = irw - endif - if (idx<0) then - write(debug_unit,*) trim(name),& - &' Error : idx no good ',idx - info = 2 - return - end if - - if (append) then - nzin_ = nzin - else - nzin_ = 0 - endif - - if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then - ! In this case we can do a binary search. - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': srtdcoo ' - do - ip = psb_ibsrch(irw,nza,a%ia1) - if (ip /= -1) exit - irw = irw + 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,idx - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia1(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_ibsrch(lrw,nza,a%ia1) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia1(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nz = jp - ip +1 - - call psb_ensure_size(nzin_+nz,ia,info) - if (info==0) call psb_ensure_size(nzin_+nz,ja,info) - if (info==0) call psb_ensure_size(nzin_+nz,val,info) - if (info /= 0) return - - if (present(iren)) then - do i=ip,jp - nzin_ = nzin_ + 1 - val(nzin_) = a%aspk(i) - ia(nzin_) = iren(a%ia1(i)) - ja(nzin_) = iren(a%ia2(i)) - enddo - else - do i=ip,jp - nzin_ = nzin_ + 1 - val(nzin_) = a%aspk(i) - ia(nzin_) = a%ia1(i) - ja(nzin_) = a%ia2(i) - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - nzt = (nza*(lrw-irw+1))/max(a%m,1) - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return - - if (present(iren)) then - k = 0 - do i=1, a%infoa(psb_nnz_) - if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then - k = k + 1 - if (k > nzt) then - nzt = k - call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return - end if - val(nzin_+k) = a%aspk(i) - ia(nzin_+k) = iren(a%ia1(i)) - ja(nzin_+k) = iren(a%ia2(i)) - endif - enddo - else - k = 0 - do i=1,a%infoa(psb_nnz_) - if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then - k = k + 1 - if (k > nzt) then - nzt = k - call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return - - end if - val(nzin_+k) = a%aspk(i) - ia(nzin_+k) = (a%ia1(i)) - ja(nzin_+k) = (a%ia2(i)) - endif - enddo - nzin_=nzin_+k - end if - nz = k - end if - - end subroutine coo_cspgtrow - - - subroutine jad_cspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) - - use psb_sort_mod - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_cspmat_type), intent(in), target :: a - integer :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_spk_), allocatable, intent(inout) :: val(:) - integer :: nzin - logical, intent(in) :: append - integer, optional :: iren(:) - integer :: lrw,info - - integer, pointer :: ia1(:), ia2(:), ia3(:),& - & ja_(:), ka_(:), indices(:), blks(:) - integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng, nzin_,& - & i,j,k,nr - - - png = a%ia2(1) ! points to the number of blocks - pia = a%ia2(2) ! points to the beginning of ia(3,png) - pja = a%ia2(3) ! points to the beginning of ja(:) - - ng = a%ia2(png) ! the number of blocks - ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk - ka_ => a%ia1(:) ! the array containing the column indices - ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index of each block - ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. in ja to the first jad column - ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. in ja to the first csr column - - if (append) then - nzin_ = nzin - else - nzin_ = 0 - endif - - if (a%pl(1) /= 0) then - - nr = lrw - irw + 1 - allocate(indices(nr),blks(nr)) - nz = 0 - - do i=1,nr - indices(i)=a%pl(irw+i-1) - j=0 - blkfnd: do - j=j+1 - if(ia1(j) == indices(i)) then - blks(i)=j - nz=nz+ia3(j)-ia2(j) - ipx = ia1(j) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j)+rb - nz = nz+ja_(row+1)-ja_(row) - exit blkfnd - else if(ia1(j) > indices(i)) then - blks(i)=j-1 - nz=nz+ia3(j-1)-ia2(j-1) - ipx = ia1(j-1) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j-1)+rb - nz = nz+ja_(row+1)-ja_(row) - exit blkfnd - end if - end do blkfnd - end do - - - call psb_ensure_size(nzin_+nz,ia,info) - if (info==0) call psb_ensure_size(nzin_+nz,ja,info) - if (info==0) call psb_ensure_size(nzin_+nz,val,info) - if (info /= 0) return - - k=0 - ! cycle over rows - do i=1,nr - - ! find which block the row belongs to - blk = blks(i) - - ! extract first part of the row from the jad block - ipx = ia1(blk) ! the first row index of the block - k_pt= ia2(blk) ! the pointer to the beginning of a column in ja - rb = indices(i)-ipx ! the row offset within the block - npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block - - if(present(iren))then - do col = ia2(blk), ia3(blk)-1 - k=k+1 - val(nzin_+k) = a%aspk(ja_(col)+rb) - ia(nzin_+k) = iren(irw+i-1) - ja(nzin_+k) = iren(ka_(ja_(col)+rb)) - end do - else - do col = ia2(blk), ia3(blk)-1 - k=k+1 - val(nzin_+k) = a%aspk(ja_(col)+rb) - ia(nzin_+k) = irw+i-1 - ja(nzin_+k) = ka_(ja_(col)+rb) - end do - end if - ! extract second part of the row from the csr tail - row=ia3(blk)+rb - if(present(iren))then - do j=ja_(row), ja_(row+1)-1 - k=k+1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = iren(irw+i-1) - ja(nzin_+k) = iren(ka_(j)) - end do - else - do j=ja_(row), ja_(row+1)-1 - k=k+1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = irw+i-1 - ja(nzin_+k) = ka_(j) - end do - end if - end do - - else - ! There might be some problems - info=134 - end if - - end subroutine jad_cspgtrow - - - subroutine csr_zspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) - - use psb_sort_mod - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer :: nzin - logical, intent(in) :: append - integer :: lrw,info - integer, optional :: iren(:) - - integer :: idx,i,j, k, nr, row_idx, nzin_ - integer, allocatable :: indices(:) - integer :: debug_level, debug_unit - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (append) then - nzin_ = nzin - else - nzin_ = 0 - endif - - if (a%pl(1) /= 0) then - - nr = lrw - irw + 1 - allocate(indices(nr)) - nz = 0 - do i=1,nr - indices(i)=a%pl(irw+i-1) - nz=nz+a%ia2(indices(i)+1)-a%ia2(indices(i)) - end do - - call psb_ensure_size(nzin_+nz,ia,info) - if (info==0) call psb_ensure_size(nzin_+nz,ja,info) - if (info==0) call psb_ensure_size(nzin_+nz,val,info) - if (info /= 0) return - - k=0 - if(present(iren)) then - do i=1,nr - row_idx=indices(i) - do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 - k = k + 1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = iren(row_idx) - ja(nzin_+k) = iren(a%ia1(j)) - end do - end do - else - do i=1,nr - row_idx=indices(i) - do j=a%ia2(row_idx),a%ia2(row_idx+1)-1 - k = k + 1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = row_idx - ja(nzin_+k) = a%ia1(j) - end do - end do - end if - - else - idx = irw - - if (idx<0) then - write(0,*) ' spgtrow Error : idx no good ',idx - return - end if - nr = lrw - irw + 1 - nz = a%ia2(idx+nr) - a%ia2(idx) - - call psb_ensure_size(nzin_+nz,ia,info) - if (info==0) call psb_ensure_size(nzin_+nz,ja,info) - if (info==0) call psb_ensure_size(nzin_+nz,val,info) - if (info /= 0) return - - - if (present(iren)) then - k=0 - do i=irw,lrw - do j=a%ia2(i),a%ia2(i+1)-1 - k = k + 1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = iren(i) - ja(nzin_+k) = iren(a%ia1(j)) - end do - enddo - else - k=0 - - do i=irw,lrw - do j=a%ia2(i),a%ia2(i+1)-1 - k = k + 1 - ia(nzin_+k) = i - ja(nzin_+k) = a%ia1(j) - val(nzin_+k) = a%aspk(j) - end do - enddo - end if - if (a%pr(1) /= 0) then - write(debug_unit,*)& - & 'Feeling lazy today, Right Permutation will have to wait' - endif - - endif - - end subroutine csr_zspgtrow - - - subroutine coo_zspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) - - use psb_sort_mod - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer :: nzin - logical, intent(in) :: append - integer :: lrw,info - integer, optional :: iren(:) - integer :: nzin_, nza, idx,ip,jp,i,k, nzt - integer :: debug_level, debug_unit - character(len=20) :: name='coo_zspgtrow' - - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - nza = a%infoa(psb_nnz_) - if (a%pl(1) /= 0) then - write(debug_unit,*) trim(name),& - & 'Fatal error: do not feed a permuted mat so far!' - idx = -1 - else - idx = irw - endif - if (idx<0) then - write(debug_unit,*) trim(name),& - &' Error : idx no good ',idx - info = 2 - return - end if - - if (append) then - nzin_ = nzin - else - nzin_ = 0 - endif - - if (a%infoa(psb_srtd_) == psb_isrtdcoo_) then - ! In this case we can do a binary search. - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': srtdcoo ' - do - ip = psb_ibsrch(irw,nza,a%ia1) - if (ip /= -1) exit - irw = irw + 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error? ',& - & irw,lrw,idx - exit - end if - end do - - if (ip /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (ip < 2) exit - if (a%ia1(ip-1) == irw) then - ip = ip -1 - else - exit - end if - end do - - end if - - do - jp = psb_ibsrch(lrw,nza,a%ia1) - if (jp /= -1) exit - lrw = lrw - 1 - if (irw > lrw) then - write(debug_unit,*) trim(name),& - & 'Warning : did not find any rows. Is this an error?' - exit - end if - end do - - if (jp /= -1) then - ! expand [ip,jp] to contain all row entries. - do - if (jp == nza) exit - if (a%ia1(jp+1) == lrw) then - jp = jp + 1 - else - exit - end if - end do - end if - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': ip jp',ip,jp,nza - if ((ip /= -1) .and.(jp /= -1)) then - ! Now do the copy. - nz = jp - ip +1 - - call psb_ensure_size(nzin_+nz,ia,info) - if (info==0) call psb_ensure_size(nzin_+nz,ja,info) - if (info==0) call psb_ensure_size(nzin_+nz,val,info) - if (info /= 0) return - - if (present(iren)) then - do i=ip,jp - nzin_ = nzin_ + 1 - val(nzin_) = a%aspk(i) - ia(nzin_) = iren(a%ia1(i)) - ja(nzin_) = iren(a%ia2(i)) - enddo - else - do i=ip,jp - nzin_ = nzin_ + 1 - val(nzin_) = a%aspk(i) - ia(nzin_) = a%ia1(i) - ja(nzin_) = a%ia2(i) - enddo - end if - else - nz = 0 - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': unsorted ' - nzt = (nza*(lrw-irw+1))/max(a%m,1) - - call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return - - if (present(iren)) then - k = 0 - do i=1, a%infoa(psb_nnz_) - if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then - k = k + 1 - if (k > nzt) then - nzt = k - call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return - end if - val(nzin_+k) = a%aspk(i) - ia(nzin_+k) = iren(a%ia1(i)) - ja(nzin_+k) = iren(a%ia2(i)) - endif - enddo - else - k = 0 - do i=1,a%infoa(psb_nnz_) - if ((a%ia1(i)>=irw).and.(a%ia1(i)<=lrw)) then - k = k + 1 - if (k > nzt) then - nzt = k - call psb_ensure_size(nzin_+nzt,ia,info) - if (info==0) call psb_ensure_size(nzin_+nzt,ja,info) - if (info==0) call psb_ensure_size(nzin_+nzt,val,info) - if (info /= 0) return - - end if - val(nzin_+k) = a%aspk(i) - ia(nzin_+k) = (a%ia1(i)) - ja(nzin_+k) = (a%ia2(i)) - endif - enddo - nzin_=nzin_+k - end if - nz = k - end if - - end subroutine coo_zspgtrow - - - subroutine jad_zspgtrow(irw,a,nz,ia,ja,val,nzin,append,lrw,info,iren) - - use psb_sort_mod - use psb_spmat_type - use psb_const_mod - implicit none - - type(psb_zspmat_type), intent(in), target :: a - integer :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer :: nzin - logical, intent(in) :: append - integer, optional :: iren(:) - integer :: lrw,info - - integer, pointer :: ia1(:), ia2(:), ia3(:),& - & ja_(:), ka_(:), indices(:), blks(:) - integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ng, nzin_,& - & i,j,k,nr - - - png = a%ia2(1) ! points to the number of blocks - pia = a%ia2(2) ! points to the beginning of ia(3,png) - pja = a%ia2(3) ! points to the beginning of ja(:) - - ng = a%ia2(png) ! the number of blocks - ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk - ka_ => a%ia1(:) ! the array containing the column indices - ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index of each block - ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. in ja to the first jad column - ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. in ja to the first csr column - - if (append) then - nzin_ = nzin - else - nzin_ = 0 - endif - - if (a%pl(1) /= 0) then - - nr = lrw - irw + 1 - allocate(indices(nr),blks(nr)) - nz = 0 - - do i=1,nr - indices(i)=a%pl(irw+i-1) - j=0 - blkfnd: do - j=j+1 - if(ia1(j) == indices(i)) then - blks(i)=j - nz=nz+ia3(j)-ia2(j) - ipx = ia1(j) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j)+rb - nz = nz+ja_(row+1)-ja_(row) - exit blkfnd - else if(ia1(j) > indices(i)) then - blks(i)=j-1 - nz=nz+ia3(j-1)-ia2(j-1) - ipx = ia1(j-1) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j-1)+rb - nz = nz+ja_(row+1)-ja_(row) - exit blkfnd - end if - end do blkfnd - end do - - - call psb_ensure_size(nzin_+nz,ia,info) - if (info==0) call psb_ensure_size(nzin_+nz,ja,info) - if (info==0) call psb_ensure_size(nzin_+nz,val,info) - if (info /= 0) return - - k=0 - ! cycle over rows - do i=1,nr - - ! find which block the row belongs to - blk = blks(i) - - ! extract first part of the row from the jad block - ipx = ia1(blk) ! the first row index of the block - k_pt= ia2(blk) ! the pointer to the beginning of a column in ja - rb = indices(i)-ipx ! the row offset within the block - npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block - - if(present(iren))then - do col = ia2(blk), ia3(blk)-1 - k=k+1 - val(nzin_+k) = a%aspk(ja_(col)+rb) - ia(nzin_+k) = iren(irw+i-1) - ja(nzin_+k) = iren(ka_(ja_(col)+rb)) - end do - else - do col = ia2(blk), ia3(blk)-1 - k=k+1 - val(nzin_+k) = a%aspk(ja_(col)+rb) - ia(nzin_+k) = irw+i-1 - ja(nzin_+k) = ka_(ja_(col)+rb) - end do - end if - ! extract second part of the row from the csr tail - row=ia3(blk)+rb - if(present(iren))then - do j=ja_(row), ja_(row+1)-1 - k=k+1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = iren(irw+i-1) - ja(nzin_+k) = iren(ka_(j)) - end do - else - do j=ja_(row), ja_(row+1)-1 - k=k+1 - val(nzin_+k) = a%aspk(j) - ia(nzin_+k) = irw+i-1 - ja(nzin_+k) = ka_(j) - end do - end if - end do - - else - ! There might be some problems - info=134 - end if - - end subroutine jad_zspgtrow - - -end module psb_getrow_mod diff --git a/base/serial/psb_regen_mod.f90 b/base/serial/psb_regen_mod.f90 deleted file mode 100644 index a4b490ca1..000000000 --- a/base/serial/psb_regen_mod.f90 +++ /dev/null @@ -1,1312 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -module psb_regen_mod - - interface csr_regen - module procedure csr_csp_regen, csr_zsp_regen - end interface - interface coo_regen - module procedure coo_csp_regen, coo_zsp_regen - end interface - interface jad_regen - module procedure jad_csp_regen, jad_zsp_regen - end interface - -contains - -!!$ subroutine csr_ssp_regen(a,info) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(inout) :: a -!!$ integer :: info -!!$ -!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt -!!$ real(psb_spk_), allocatable :: work(:) -!!$ integer :: err_act -!!$ character(len=20) :: name -!!$ integer :: debug_level, debug_unit -!!$ -!!$ -!!$ name='psb_spcnv' -!!$ info = 0 -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ -!!$ ! -!!$ ! dupl_ and upd_ fields should not be changed. -!!$ ! -!!$ select case(psb_sp_getifld(psb_upd_,a,info)) -!!$ -!!$ case(psb_upd_perm_) -!!$ -!!$ allocate(work(size(a%aspk)+1000),stat=info) -!!$ if (info /= 0) then -!!$ info=2040 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' -!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) -!!$ ip2 = a%ia2(ip1+psb_ip2_) -!!$ nnz = a%ia2(ip1+psb_nnz_) -!!$ iflag = a%ia2(ip1+psb_iflag_) -!!$ ichk = a%ia2(ip1+psb_ichk_) -!!$ nnzt = a%ia2(ip1+psb_nnzt_) -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info -!!$ -!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then -!!$ info = 8889 -!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ do i= 1, nnz -!!$ work(i) = dzero -!!$ enddo -!!$ select case(iflag) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ do i=1, nnz -!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) -!!$ enddo -!!$ case(psb_dupl_add_) -!!$ do i=1, nnz -!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) -!!$ enddo -!!$ case default -!!$ info = 8887 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, nnz -!!$ a%aspk(i) = work(i) -!!$ enddo -!!$ -!!$ -!!$ case(psb_upd_srch_) -!!$ ! Nothing to be done here. -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),& -!!$ & 'Going through on regeneration with psb_upd_srch_' -!!$ case default -!!$ ! Wrong value -!!$ info = 8888 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ -!!$ end select -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$ end subroutine csr_ssp_regen -!!$ -!!$ subroutine coo_ssp_regen(a,info) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(inout) :: a -!!$ integer :: info -!!$ -!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt -!!$ real(psb_spk_), allocatable :: work(:) -!!$ integer :: err_act -!!$ character(len=20) :: name -!!$ integer :: debug_level, debug_unit -!!$ -!!$ -!!$ name='psb_spcnv' -!!$ info = 0 -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ -!!$ ! -!!$ ! dupl_ and upd_ fields should not be changed. -!!$ ! -!!$ select case(psb_sp_getifld(psb_upd_,a,info)) -!!$ -!!$ case(psb_upd_perm_) -!!$ -!!$ allocate(work(size(a%aspk)+1000),stat=info) -!!$ if (info /= 0) then -!!$ info=2040 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' -!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) -!!$ ip2 = a%ia2(ip1+psb_ip2_) -!!$ nnz = a%ia2(ip1+psb_nnz_) -!!$ iflag = a%ia2(ip1+psb_iflag_) -!!$ ichk = a%ia2(ip1+psb_ichk_) -!!$ nnzt = a%ia2(ip1+psb_nnzt_) -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info -!!$ -!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then -!!$ info = 8889 -!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ do i= 1, nnz -!!$ work(i) = dzero -!!$ enddo -!!$ select case(iflag) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ do i=1, nnz -!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) -!!$ enddo -!!$ case(psb_dupl_add_) -!!$ do i=1, nnz -!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) -!!$ enddo -!!$ case default -!!$ info = 8887 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, nnz -!!$ a%aspk(i) = work(i) -!!$ enddo -!!$ -!!$ -!!$ case(psb_upd_srch_) -!!$ ! Nothing to be done here. -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & 'Going through on regeneration with psb_upd_srch_' -!!$ case default -!!$ ! Wrong value -!!$ info = 8888 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ -!!$ end select -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$ end subroutine coo_ssp_regen -!!$ -!!$ subroutine jad_ssp_regen(a,info) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(inout) :: a -!!$ integer :: info -!!$ -!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt -!!$ real(psb_spk_), allocatable :: work(:) -!!$ integer :: err_act -!!$ character(len=20) :: name -!!$ integer :: debug_level, debug_unit -!!$ -!!$ name='psb_spcnv' -!!$ info = 0 -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ -!!$ ! -!!$ ! dupl_ and upd_ fields should not be changed. -!!$ ! -!!$ select case(psb_sp_getifld(psb_upd_,a,info)) -!!$ -!!$ case(psb_upd_perm_) -!!$ -!!$ allocate(work(size(a%aspk)+1000),stat=info) -!!$ if (info /= 0) then -!!$ info=2040 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' -!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) -!!$ ip2 = a%ia1(ip1+psb_ip2_) -!!$ nnz = a%ia1(ip1+psb_nnz_) -!!$ iflag = a%ia1(ip1+psb_iflag_) -!!$ ichk = a%ia1(ip1+psb_ichk_) -!!$ nnzt = a%ia1(ip1+psb_nnzt_) -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info -!!$ -!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then -!!$ info = 8889 -!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ do i= 1, nnz -!!$ work(i) = dzero -!!$ enddo -!!$ select case(iflag) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ do i=1, nnz -!!$ work(a%ia1(ip2+i-1)) = a%aspk(i) -!!$ enddo -!!$ case(psb_dupl_add_) -!!$ do i=1, nnz -!!$ work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1)) -!!$ enddo -!!$ case default -!!$ info = 8887 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, nnz -!!$ a%aspk(i) = work(i) -!!$ enddo -!!$ -!!$ -!!$ case(psb_upd_srch_) -!!$ ! Nothing to be done here. -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),& -!!$ & 'Going through on regeneration with psb_upd_srch_' -!!$ case default -!!$ ! Wrong value -!!$ info = 8888 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ -!!$ end select -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$ end subroutine jad_ssp_regen -!!$ -!!$ subroutine csr_dsp_regen(a,info) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(inout) :: a -!!$ integer :: info -!!$ -!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt -!!$ real(psb_dpk_), allocatable :: work(:) -!!$ integer :: err_act -!!$ character(len=20) :: name -!!$ integer :: debug_level, debug_unit -!!$ -!!$ -!!$ name='psb_spcnv' -!!$ info = 0 -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ -!!$ ! -!!$ ! dupl_ and upd_ fields should not be changed. -!!$ ! -!!$ select case(psb_sp_getifld(psb_upd_,a,info)) -!!$ -!!$ case(psb_upd_perm_) -!!$ -!!$ allocate(work(size(a%aspk)+1000),stat=info) -!!$ if (info /= 0) then -!!$ info=2040 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' -!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) -!!$ ip2 = a%ia2(ip1+psb_ip2_) -!!$ nnz = a%ia2(ip1+psb_nnz_) -!!$ iflag = a%ia2(ip1+psb_iflag_) -!!$ ichk = a%ia2(ip1+psb_ichk_) -!!$ nnzt = a%ia2(ip1+psb_nnzt_) -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info -!!$ -!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then -!!$ info = 8889 -!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ do i= 1, nnz -!!$ work(i) = dzero -!!$ enddo -!!$ select case(iflag) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ do i=1, nnz -!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) -!!$ enddo -!!$ case(psb_dupl_add_) -!!$ do i=1, nnz -!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) -!!$ enddo -!!$ case default -!!$ info = 8887 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, nnz -!!$ a%aspk(i) = work(i) -!!$ enddo -!!$ -!!$ -!!$ case(psb_upd_srch_) -!!$ ! Nothing to be done here. -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),& -!!$ & 'Going through on regeneration with psb_upd_srch_' -!!$ case default -!!$ ! Wrong value -!!$ info = 8888 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ -!!$ end select -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$ end subroutine csr_dsp_regen -!!$ -!!$ subroutine coo_dsp_regen(a,info) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(inout) :: a -!!$ integer :: info -!!$ -!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt -!!$ real(psb_dpk_), allocatable :: work(:) -!!$ integer :: err_act -!!$ character(len=20) :: name -!!$ integer :: debug_level, debug_unit -!!$ -!!$ -!!$ name='psb_spcnv' -!!$ info = 0 -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ -!!$ ! -!!$ ! dupl_ and upd_ fields should not be changed. -!!$ ! -!!$ select case(psb_sp_getifld(psb_upd_,a,info)) -!!$ -!!$ case(psb_upd_perm_) -!!$ -!!$ allocate(work(size(a%aspk)+1000),stat=info) -!!$ if (info /= 0) then -!!$ info=2040 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' -!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) -!!$ ip2 = a%ia2(ip1+psb_ip2_) -!!$ nnz = a%ia2(ip1+psb_nnz_) -!!$ iflag = a%ia2(ip1+psb_iflag_) -!!$ ichk = a%ia2(ip1+psb_ichk_) -!!$ nnzt = a%ia2(ip1+psb_nnzt_) -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info -!!$ -!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then -!!$ info = 8889 -!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ do i= 1, nnz -!!$ work(i) = dzero -!!$ enddo -!!$ select case(iflag) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ do i=1, nnz -!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) -!!$ enddo -!!$ case(psb_dupl_add_) -!!$ do i=1, nnz -!!$ work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) -!!$ enddo -!!$ case default -!!$ info = 8887 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, nnz -!!$ a%aspk(i) = work(i) -!!$ enddo -!!$ -!!$ -!!$ case(psb_upd_srch_) -!!$ ! Nothing to be done here. -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & 'Going through on regeneration with psb_upd_srch_' -!!$ case default -!!$ ! Wrong value -!!$ info = 8888 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ -!!$ end select -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$ end subroutine coo_dsp_regen -!!$ -!!$ subroutine jad_dsp_regen(a,info) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(inout) :: a -!!$ integer :: info -!!$ -!!$ integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt -!!$ real(psb_dpk_), allocatable :: work(:) -!!$ integer :: err_act -!!$ character(len=20) :: name -!!$ integer :: debug_level, debug_unit -!!$ -!!$ name='psb_spcnv' -!!$ info = 0 -!!$ call psb_erractionsave(err_act) -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ -!!$ ! -!!$ ! dupl_ and upd_ fields should not be changed. -!!$ ! -!!$ select case(psb_sp_getifld(psb_upd_,a,info)) -!!$ -!!$ case(psb_upd_perm_) -!!$ -!!$ allocate(work(size(a%aspk)+1000),stat=info) -!!$ if (info /= 0) then -!!$ info=2040 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end if -!!$ -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' -!!$ ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) -!!$ ip2 = a%ia1(ip1+psb_ip2_) -!!$ nnz = a%ia1(ip1+psb_nnz_) -!!$ iflag = a%ia1(ip1+psb_iflag_) -!!$ ichk = a%ia1(ip1+psb_ichk_) -!!$ nnzt = a%ia1(ip1+psb_nnzt_) -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),'Regeneration start: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info -!!$ -!!$ if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then -!!$ info = 8889 -!!$ write(debug_unit,*) trim(name),'Regeneration start error: ',& -!!$ & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ endif -!!$ do i= 1, nnz -!!$ work(i) = dzero -!!$ enddo -!!$ select case(iflag) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ do i=1, nnz -!!$ work(a%ia1(ip2+i-1)) = a%aspk(i) -!!$ enddo -!!$ case(psb_dupl_add_) -!!$ do i=1, nnz -!!$ work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1)) -!!$ enddo -!!$ case default -!!$ info = 8887 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ end select -!!$ -!!$ do i=1, nnz -!!$ a%aspk(i) = work(i) -!!$ enddo -!!$ -!!$ -!!$ case(psb_upd_srch_) -!!$ ! Nothing to be done here. -!!$ if (debug_level >= psb_debug_serial_)& -!!$ & write(debug_unit,*) trim(name),& -!!$ & 'Going through on regeneration with psb_upd_srch_' -!!$ case default -!!$ ! Wrong value -!!$ info = 8888 -!!$ call psb_errpush(info,name) -!!$ goto 9999 -!!$ -!!$ end select -!!$ -!!$ call psb_erractionrestore(err_act) -!!$ return -!!$ -!!$9999 continue -!!$ call psb_erractionrestore(err_act) -!!$ if (err_act == psb_act_abort_) then -!!$ call psb_error() -!!$ return -!!$ end if -!!$ return -!!$ -!!$ end subroutine jad_dsp_regen -!!$ - - subroutine csr_csp_regen(a,info) - - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer :: info - - integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt - complex(psb_spk_), allocatable :: work(:) - integer :: err_act - character(len=20) :: name - integer :: debug_level, debug_unit - - name='psb_spcnv' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! - ! dupl_ and upd_ fields should not be changed. - ! - select case(psb_sp_getifld(psb_upd_,a,info)) - - case(psb_upd_perm_) - - allocate(work(size(a%aspk)+1000),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - ip2 = a%ia2(ip1+psb_ip2_) - nnz = a%ia2(ip1+psb_nnz_) - iflag = a%ia2(ip1+psb_iflag_) - ichk = a%ia2(ip1+psb_ichk_) - nnzt = a%ia2(ip1+psb_nnzt_) - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),'Regeneration start: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 8889 - write(debug_unit,*) trim(name),'Regeneration start error: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - do i= 1, nnz - work(i) = zzero - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(a%ia2(ip2+i-1)) = a%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz - a%aspk(i) = work(i) - enddo - - - case(psb_upd_srch_) - ! Nothing to be done here. - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & 'Going through on regeneration with psb_upd_srch_' - case default - ! Wrong value - info = 8888 - call psb_errpush(info,name) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csr_csp_regen - - subroutine coo_csp_regen(a,info) - - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer :: info - - integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt - complex(psb_spk_), allocatable :: work(:) - integer :: err_act - character(len=20) :: name - integer :: debug_level, debug_unit - - name='psb_spcnv' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ! - ! dupl_ and upd_ fields should not be changed. - ! - select case(psb_sp_getifld(psb_upd_,a,info)) - - case(psb_upd_perm_) - - allocate(work(size(a%aspk)+1000),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - ip2 = a%ia2(ip1+psb_ip2_) - nnz = a%ia2(ip1+psb_nnz_) - iflag = a%ia2(ip1+psb_iflag_) - ichk = a%ia2(ip1+psb_ichk_) - nnzt = a%ia2(ip1+psb_nnzt_) - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),'Regeneration start: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 8889 - write(debug_unit,*) trim(name),'Regeneration start error: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - do i= 1, nnz - work(i) = zzero - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(a%ia2(ip2+i-1)) = a%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz - a%aspk(i) = work(i) - enddo - - - case(psb_upd_srch_) - ! Nothing to be done here. - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & 'Going through on regeneration with psb_upd_srch_' - case default - ! Wrong value - info = 8888 - call psb_errpush(info,name) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine coo_csp_regen - - subroutine jad_csp_regen(a,info) - - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer :: info - - integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt - complex(psb_spk_), allocatable :: work(:) - integer :: err_act - character(len=20) :: name - integer :: debug_level, debug_unit - - name='psb_spcnv' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! - ! dupl_ and upd_ fields should not be changed. - ! - select case(psb_sp_getifld(psb_upd_,a,info)) - - case(psb_upd_perm_) - - allocate(work(size(a%aspk)+1000),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - ip2 = a%ia1(ip1+psb_ip2_) - nnz = a%ia1(ip1+psb_nnz_) - iflag = a%ia1(ip1+psb_iflag_) - ichk = a%ia1(ip1+psb_ichk_) - nnzt = a%ia1(ip1+psb_nnzt_) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),'Regeneration start: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 8889 - write(debug_unit,*) trim(name),'Regeneration start error: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - do i= 1, nnz - work(i) = zzero - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(a%ia1(ip2+i-1)) = a%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz - a%aspk(i) = work(i) - enddo - - - case(psb_upd_srch_) - ! Nothing to be done here. - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & 'Going through on regeneration with psb_upd_srch_' - case default - ! Wrong value - info = 8888 - call psb_errpush(info,name) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine jad_csp_regen - - - subroutine csr_zsp_regen(a,info) - - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer :: info - - integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt - complex(psb_dpk_), allocatable :: work(:) - integer :: err_act - character(len=20) :: name - integer :: debug_level, debug_unit - - name='psb_spcnv' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! - ! dupl_ and upd_ fields should not be changed. - ! - select case(psb_sp_getifld(psb_upd_,a,info)) - - case(psb_upd_perm_) - - allocate(work(size(a%aspk)+1000),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - ip2 = a%ia2(ip1+psb_ip2_) - nnz = a%ia2(ip1+psb_nnz_) - iflag = a%ia2(ip1+psb_iflag_) - ichk = a%ia2(ip1+psb_ichk_) - nnzt = a%ia2(ip1+psb_nnzt_) - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),'Regeneration start: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 8889 - write(debug_unit,*) trim(name),'Regeneration start error: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - do i= 1, nnz - work(i) = zzero - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(a%ia2(ip2+i-1)) = a%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz - a%aspk(i) = work(i) - enddo - - - case(psb_upd_srch_) - ! Nothing to be done here. - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & 'Going through on regeneration with psb_upd_srch_' - case default - ! Wrong value - info = 8888 - call psb_errpush(info,name) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine csr_zsp_regen - - subroutine coo_zsp_regen(a,info) - - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer :: info - - integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt - complex(psb_dpk_), allocatable :: work(:) - integer :: err_act - character(len=20) :: name - integer :: debug_level, debug_unit - - name='psb_spcnv' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ! - ! dupl_ and upd_ fields should not be changed. - ! - select case(psb_sp_getifld(psb_upd_,a,info)) - - case(psb_upd_perm_) - - allocate(work(size(a%aspk)+1000),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - ip2 = a%ia2(ip1+psb_ip2_) - nnz = a%ia2(ip1+psb_nnz_) - iflag = a%ia2(ip1+psb_iflag_) - ichk = a%ia2(ip1+psb_ichk_) - nnzt = a%ia2(ip1+psb_nnzt_) - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),'Regeneration start: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 8889 - write(debug_unit,*) trim(name),'Regeneration start error: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - do i= 1, nnz - work(i) = zzero - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(a%ia2(ip2+i-1)) = a%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(a%ia2(ip2+i-1)) = a%aspk(i) + work(a%ia2(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz - a%aspk(i) = work(i) - enddo - - - case(psb_upd_srch_) - ! Nothing to be done here. - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & 'Going through on regeneration with psb_upd_srch_' - case default - ! Wrong value - info = 8888 - call psb_errpush(info,name) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine coo_zsp_regen - - subroutine jad_zsp_regen(a,info) - - use psb_spmat_type - use psb_const_mod - use psb_error_mod - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer :: info - - integer :: i, ip1,ip2,nnz,iflag,ichk,nnzt - complex(psb_dpk_), allocatable :: work(:) - integer :: err_act - character(len=20) :: name - integer :: debug_level, debug_unit - - name='psb_spcnv' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - - ! - ! dupl_ and upd_ fields should not be changed. - ! - select case(psb_sp_getifld(psb_upd_,a,info)) - - case(psb_upd_perm_) - - allocate(work(size(a%aspk)+1000),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),'Regeneration with psb_upd_perm_' - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - ip2 = a%ia1(ip1+psb_ip2_) - nnz = a%ia1(ip1+psb_nnz_) - iflag = a%ia1(ip1+psb_iflag_) - ichk = a%ia1(ip1+psb_ichk_) - nnzt = a%ia1(ip1+psb_nnzt_) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),'Regeneration start: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,info - - if ((ichk/=nnzt+iflag).or.(nnz/=nnzt)) then - info = 8889 - write(debug_unit,*) trim(name),'Regeneration start error: ',& - & a%infoa(psb_upd_),psb_upd_perm_,nnz,nnzt ,iflag,ichk - call psb_errpush(info,name) - goto 9999 - endif - do i= 1, nnz - work(i) = zzero - enddo - select case(iflag) - case(psb_dupl_ovwrt_,psb_dupl_err_) - do i=1, nnz - work(a%ia1(ip2+i-1)) = a%aspk(i) - enddo - case(psb_dupl_add_) - do i=1, nnz - work(a%ia1(ip2+i-1)) = a%aspk(i) + work(a%ia1(ip2+i-1)) - enddo - case default - info = 8887 - call psb_errpush(info,name) - goto 9999 - end select - - do i=1, nnz - a%aspk(i) = work(i) - enddo - - - case(psb_upd_srch_) - ! Nothing to be done here. - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & 'Going through on regeneration with psb_upd_srch_' - case default - ! Wrong value - info = 8888 - call psb_errpush(info,name) - goto 9999 - - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - end subroutine jad_zsp_regen - - - -end module psb_regen_mod diff --git a/base/serial/psb_scoins.f90 b/base/serial/psb_scoins.f90 deleted file mode 100644 index 54821c8c8..000000000 --- a/base/serial/psb_scoins.f90 +++ /dev/null @@ -1,622 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_scoins.f90 -! Subroutine: psb_scoins -! Takes a cloud of coefficients and inserts them into a sparse matrix. -! This subroutine is the serial, inner counterpart to the outer, user-level -! psb_spins. -! -! Arguments: -! -! nz - integer, input The number of points to insert. -! ia(:) - integer, input The row indices of the coefficients. -! ja(:) - integer, input The column indices of the coefficients. -! val(:) - real, input The values of the coefficients to be inserted. -! a - type(psb_sspmat_type), inout The sparse destination matrix. -! imin - integer, input The minimum valid row index -! imax - integer, input The maximum valid row index -! jmin - integer, input The minimum valid col index -! jmax - integer, input The maximum valid col index -! info - integer, output Return code. -! gtl(:) - integer, input,optional An index mapping to be applied -! default: identity -! rebuild - logical, input, optional Rebuild in case of update -! finding a new index. Default: false. -! Not fully tested. -! -subroutine psb_scoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_error_mod - use psb_serial_mod, psb_protect_name => psb_scoins - use psb_update_mod - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax - integer, intent(in) :: ia(:),ja(:) - real(psb_spk_), intent(in) :: val(:) - type(psb_sspmat_type), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - logical, intent(in), optional :: rebuild - - character(len=5) :: ufida - integer :: ng, nza, isza,spstate, & - & ip1, nzl, err_act, int_err(5), iupd, irst - integer :: debug_level, debug_unit - logical :: rebuild_ - character(len=20) :: name, ch_err - type(psb_sspmat_type) :: tmp - - name='psb_scoins' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - info = 0 - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (present(rebuild)) then - rebuild_ = rebuild - else - rebuild_ = .false. - end if - - ufida = psb_toupper(a%fida) - spstate = psb_sp_getifld(psb_state_,a,info) - - - if (present(gtl)) then - - ng = size(gtl) - select case(spstate) - case(psb_spmat_bld_) - if ((ufida /= 'COO').and.(ufida/='COI')) then - info = 134 - ch_err(1:3)=ufida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info,gtl,ng) - - if(info /= izero) then - - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%infoa(psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': insert discarded items ' - end if - end if - if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - endif - call psb_sp_setifld(nza,psb_nnz_,a,info) - - case(psb_spmat_upd_) - - iupd = psb_sp_getifld(psb_upd_,a,info) - select case (iupd) - case (psb_upd_perm_) - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - nzl = psb_sp_getifld(psb_del_bnd_,a,info) - select case(ufida) - case ('JAD') - nza = a%ia1(ip1+psb_nnz_) - case default - nza = a%ia2(ip1+psb_nnz_) - end select - - call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - if (info /= izero) then - ch_err='psb_inner_upd' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': update discarded items ' - end if - end if - - select case(ufida) - case ('JAD') - a%ia1(ip1+psb_nnz_) = nza - case default - a%ia2(ip1+psb_nnz_) = nza - end select - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': (UPD) : NZA:',nza - - case (psb_upd_srch_) - - call psb_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - if (info > 0) then - if (rebuild_) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*)& - & trim(name),& - & ': Going through rebuild_ fingers crossed!' - irst = info - call psb_nullify_sp(tmp) - call psb_spcnv(a,tmp,info,afmt='coo') - if(info /= izero) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst - call psb_move_alloc(tmp,a,info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_transfer' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) write(debug_unit,*)& - & trim(name),': Reinserting',a%fida,nza,isza,irst,nz - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - if (irst <= nz) then - call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& - & nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - &imin,imax,jmin,jmax,info,gtl,ng) - if (info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - endif - - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - call psb_sp_setifld(nza,psb_nnz_,a,info) - end if - - else - info = 2231 - call psb_errpush(info,name) - goto 9999 - end if - else if (info < 0) then - info = 2230 - call psb_errpush(info,name) - goto 9999 - - end if - - case default - - info = 2231 - call psb_errpush(info,name) - goto 9999 - end select - - - case default - info = 2232 - call psb_errpush(info,name) - goto 9999 - end select - - - - - - else - - ng = -1 - - select case(spstate) - case(psb_spmat_bld_) - if ((ufida /= 'COO').and.(ufida/='COI')) then - info = 134 - ch_err(1:3)=ufida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info) - - if(info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%infoa(psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': insert discarded items ' - end if - end if - if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - endif - call psb_sp_setifld(nza,psb_nnz_,a,info) - - case(psb_spmat_upd_) - - iupd = psb_sp_getifld(psb_upd_,a,info) - select case (iupd) - case (psb_upd_perm_) - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - nzl = psb_sp_getifld(psb_del_bnd_,a,info) - nza = a%ia2(ip1+psb_nnz_) - - - call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& - & imin,imax,jmin,jmax,nzl,info) - if (info /= izero) then - ch_err='psb_inner_upd' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) then - if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': update discarded items ' - end if - end if - a%ia2(ip1+psb_nnz_) = nza - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),':(UPD) : NZA:',nza - - case (psb_upd_srch_) - - call psb_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) - - if (info > 0) then - if (rebuild_) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*)& - & trim(name),& - & ': Going through rebuild_ fingers crossed!' - irst = info - call psb_nullify_sp(tmp) - call psb_spcnv(a,tmp,info,afmt='coo') - call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst - call psb_move_alloc(tmp,a,info) - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) write(debug_unit,*)& - & trim(name),': Reinserting',a%fida,nza,isza - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - if (irst <= nz) then - call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& - & nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info) - if (info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - endif - - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - call psb_sp_setifld(nza,psb_nnz_,a,info) - end if - - else - info = 2231 - call psb_errpush(info,name) - goto 9999 - end if - else if (info < 0) then - info = 2230 - call psb_errpush(info,name) - goto 9999 - - end if - - case default - - info = 2233 - call psb_errpush(info,name) - goto 9999 - end select - - - case default - info = 2232 - call psb_errpush(info,name) - goto 9999 - end select - endif - - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -contains - - subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,maxsz,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,maxsz - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - real(psb_spk_), intent(in) :: val(:) - real(psb_spk_), intent(inout) :: aspk(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic - character(len=20) :: name, ch_err - - - name='psb_inner_upd' - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - if ((nza > nzl)) then - do i=1, nz - nza = nza + 1 - if (nza>maxsz) then - call psb_errpush(50,name,i_err=(/7,maxsz,5,0,nza /)) - info = -71 - return - endif - aspk(nza) = val(i) - end do - else - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza>maxsz) then - info = -72 - return - endif - aspk(nza) = val(i) - end if - end if - end do - end if - else - if ((nza >= nzl)) then - do i=1, nz - nza = nza + 1 - if (nza>maxsz) then - info = -73 - return - endif - aspk(nza) = val(i) - end do - else - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza>maxsz) then - info = -74 - return - endif - aspk(nza) = val(i) - end if - end do - end if - end if - end subroutine psb_inner_upd - - subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& - & imin,imax,jmin,jmax,info,gtl,ng) - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza,ia1(:),ia2(:) - real(psb_spk_), intent(in) :: val(:) - real(psb_spk_), intent(inout) :: aspk(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic - - info = 0 - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza > maxsz) then - info = -91 - return - endif - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end if - end do - else - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza > maxsz) then - info = -92 - return - endif - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end do - end if - - end subroutine psb_inner_ins - - - -end subroutine psb_scoins - diff --git a/base/serial/psb_scsmm.f90 b/base/serial/psb_scsmm.f90 deleted file mode 100644 index c43c92ec4..000000000 --- a/base/serial/psb_scsmm.f90 +++ /dev/null @@ -1,113 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_scsmm.f90 -! Subroutine: -! Arguments: -subroutine psb_scsmm(alpha,a,b,beta,c,info,trans) - use psb_spmat_type, psb_protect_name => psb_scsmm - use psb_error_mod - implicit none - - class(psb_sspmat_type) :: a - real(psb_spk_) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans - - real(psb_spk_), allocatable :: work(:) - character :: trans_ - integer :: iwsz,m,n,k,lb,lc,err_act - character(len=20) :: name, ch_err - - name='psb_scsmm' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if (trans_=='N') then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - n = min(size(b,2),size(c,2)) - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz),stat=info) - if (info /= 0) then - info = 4010 - ch_err='allocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - call scsmm(trans_,m,n,k,alpha,& - & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - - if (info /= 0) then - info = 4010 - ch_err='Serial csmm' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - goto 9999 - end if - deallocate(work,stat=info) - - if (info /= 0) then - info = 4010 - ch_err='Deallocate' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - - goto 9999 - end if - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return -end subroutine psb_scsmm diff --git a/base/serial/psb_scsmv.f90 b/base/serial/psb_scsmv.f90 deleted file mode 100644 index 63f85a228..000000000 --- a/base/serial/psb_scsmv.f90 +++ /dev/null @@ -1,91 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_scsmv.f90 -! Subroutine: -! Arguments: - -subroutine psb_scsmv(alpha,a,b,beta,c,info,trans) - use psb_spmat_type, psb_protect_name => psb_scsmv - use psb_error_mod - - implicit none - - class(psb_sspmat_type) :: a - real(psb_spk_) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans - - real(psb_spk_), allocatable :: work(:) - character :: trans_ - integer :: iwsz,m,n,k,lb,lc, err_act - character(len=20) :: name - - name='psb_scsmv' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if (trans_=='N') then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - n = 1 - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call scsmm(trans_,m,n,k,alpha,& - & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_scsmv diff --git a/base/serial/psb_scsnmi.f90 b/base/serial/psb_scsnmi.f90 deleted file mode 100644 index aed7195df..000000000 --- a/base/serial/psb_scsnmi.f90 +++ /dev/null @@ -1,93 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_scsnmi.f90 -! Subroutine: -! Arguments: - -function psb_scsnmi(a,info,trans) - - use psb_spmat_type - use psb_error_mod - implicit none - - type(psb_sspmat_type), intent(in) :: a - integer, intent(out) :: info - character, optional :: trans - real(psb_spk_) :: psb_scsnmi - interface - function scsnmi(trans,m,n,fida,descra,a,ia1,ia2,& - & infoa,ierror) - use psb_const_mod - real(psb_spk_) :: scsnmi - integer :: m,n, ierror - character :: trans - integer :: ia1(*),ia2(*),infoa(*) - character :: descra*11, fida*5 - real(psb_spk_) :: a(*) - end function scsnmi - end interface - - integer :: err_act - character :: itrans - character(len=20) :: name, ch_err - - name='psb_scsnmi' - call psb_erractionsave(err_act) - - if(present(trans)) then - itrans=trans - else - itrans='N' - end if - - psb_scsnmi = scsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info) - if(info/=0) then - psb_scsnmi = -1 - info=4010 - ch_err='psb_scsnmi' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end function psb_scsnmi diff --git a/base/serial/psb_scsprt.f90 b/base/serial/psb_scsprt.f90 deleted file mode 100644 index 2fd34c2b2..000000000 --- a/base/serial/psb_scsprt.f90 +++ /dev/null @@ -1,199 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_scsprt.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* Print out a matrix. * -!* Should really align with the F77 version under the SERIAL dir, which * -!* does a nice printout in MatrixMarket format; this would be a quick job. * -!* * -!* Handles both a shift in the row/col indices and a fuctional transform * -!* on the indices. * -!* * -!* * -!* * -!* * -!***************************************************************************** -subroutine psb_scsprt(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_spmat_type - use psb_string_mod - implicit none - - integer, intent(in) :: iout - type(psb_sspmat_type), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate real general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% ',psb_toupper(a%fida) - endif - - nmx = max(a%m,a%k,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),es16.8,1x,2(i',ni,',1x))' - - - select case(psb_toupper(a%fida)) - - case ('CSR') - - write(iout,*) a%m,a%k,a%ia2(a%m+1)-1 - - if (present(iv)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) iv(irs+i),iv(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+i),(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+i),ivc(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+i),ivc(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+i),(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - endif - endif - - case ('CSC') - - write(iout,*) a%m,a%k,a%ia2(a%k+1)-1 - - if (present(iv)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) iv(irs+a%ia1(j)),iv(ics+i),a%aspk(j) - enddo - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+a%ia1(j)),(ics+i),a%aspk(j) - enddo - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+a%ia1(j)),ivc(ics+i),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+a%ia1(j)),ivc(ics+i),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+a%ia1(j)),(ics+i),a%aspk(j) - enddo - enddo - endif - endif - - case ('COO') - if(present(iv)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) iv(a%ia1(j)),iv(a%ia2(j)),a%aspk(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) ivr(a%ia1(j)),a%ia2(j),a%aspk(j) - enddo - else if (present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) ivr(a%ia1(j)),ivc(a%ia2(j)),a%aspk(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) a%ia1(j),ivc(a%ia2(j)),a%aspk(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) a%ia1(j),a%ia2(j),a%aspk(j) - enddo - endif - endif - case default - write(0,*) 'Feeling lazy today, format not implemented: "',a%fida,'"' - end select - -end subroutine psb_scsprt diff --git a/base/serial/psb_scssm.f90 b/base/serial/psb_scssm.f90 deleted file mode 100644 index 141368eea..000000000 --- a/base/serial/psb_scssm.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_scssm.f90 -! Subroutine: -! Arguments: - -subroutine psb_scssm(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type, psb_protect_name => psb_scssm - use psb_error_mod - implicit none - - class(psb_sspmat_type) :: t - real(psb_spk_) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans, unitd - real(psb_spk_), optional, target :: d(:) - - real(psb_spk_), allocatable :: work(:) - real(psb_spk_), pointer :: ddl(:) - character :: lt, lu - integer :: iwsz,m,n,lb,lc,err_act - character(len=20) :: name - - name='psb_scssm' - info = 0 - call psb_erractionsave(err_act) - - - if (present(trans)) then - lt = trans - else - lt = 'N' - endif - if (present(unitd)) then - lu = unitd - else - lu = 'U' - endif - if (present(d)) then - ddl => d - else - allocate(ddl(1)) - endif - - m = t%m - n = min(size(b,2),size(c,2)) - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call scssm(lt,m,n,alpha,lu,ddl,& - & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - if (.not.present(d)) then - deallocate(ddl) - endif - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_scssm diff --git a/base/serial/psb_scssv.f90 b/base/serial/psb_scssv.f90 deleted file mode 100644 index e77bd49cc..000000000 --- a/base/serial/psb_scssv.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_scssv.f90 -! Subroutine: -! Arguments: - -subroutine psb_scssv(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type, psb_protect_name => psb_scssv - use psb_error_mod - implicit none - - class(psb_sspmat_type) :: t - real(psb_spk_) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans, unitd - real(psb_spk_), optional, target :: d(:) - - real(psb_spk_), allocatable :: work(:) - real(psb_spk_), pointer :: ddl(:) - character :: lt, lu - integer :: iwsz,m,n,lb,lc,err_act - character(len=20) :: name - - name='psb_scssv' - info = 0 - call psb_erractionsave(err_act) - - - if (present(trans)) then - lt = trans - else - lt = 'N' - endif - if (present(unitd)) then - lu = unitd - else - lu = 'U' - endif - if (present(d)) then - ddl => d - else - allocate(ddl(1)) - endif - - m = t%m - n = 1 - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call scssm(lt,m,n,alpha,lu,ddl,& - & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - if (.not.present(d)) then - deallocate(ddl) - endif - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_scssv diff --git a/base/serial/psb_setifield.f90 b/base/serial/psb_setifield.f90 deleted file mode 100644 index 6fb87382a..000000000 --- a/base/serial/psb_setifield.f90 +++ /dev/null @@ -1,45 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -subroutine psb_setifield(val,field,info,isize,ierr) - integer :: val,field,isize,ierr - integer :: info(*) - - ierr = 0 - - if ((field < 1).or.(field > isize)) then - ierr = -1 - return - endif - - info(field) = val - return -end subroutine psb_setifield diff --git a/base/serial/psb_sfixcoo.f90 b/base/serial/psb_sfixcoo.f90 deleted file mode 100644 index 1d9148436..000000000 --- a/base/serial/psb_sfixcoo.f90 +++ /dev/null @@ -1,269 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sfixcoo.f90 -! Subroutine: -! Arguments: - -subroutine psb_sfixcoo(a,info,idir) - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_sfixcoo - use psb_ip_reord_mod - use psb_error_mod - implicit none - - !....Parameters... - Type(psb_sspmat_type), intent(inout) :: A - Integer, intent(out) :: info - integer, intent(in), optional :: idir - - integer, allocatable :: iaux(:) - !locals - Integer :: nza, nzl,iret,idir_, dupl_ - integer :: i,j, irw, icl, err_act - integer :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(a%ia1),size(a%ia2) - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) 'Fixcoo Invalid input ',a%fida - info = -1 - return - end if - if (present(idir)) then - idir_ = idir - else - idir_ = 0 - endif - - nza = psb_sp_getifld(psb_nnz_,a,info) - if (nza < 2) return - - dupl_ = psb_sp_getifld(psb_dupl_,a,info) - - allocate(iaux(nza+2),stat=info) - if (info /= 0) return - - select case(idir_) - - case(0) ! Row major order - - call msort_up(nza,a%ia1(1),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nza,a%aspk,a%ia1,a%ia2,iaux) - i = 1 - j = i - do while (i <= nza) - do while ((a%ia1(j) == a%ia1(i))) - j = j+1 - if (j > nza) exit - enddo - nzl = j - i - call msort_up(nzl,a%ia2(i),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,a%aspk(i:i+nzl-1),& - & a%ia1(i:i+nzl-1),a%ia2(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = a%ia1(i) - icl = a%ia2(i) - j = 1 - - select case(dupl_) - case(psb_dupl_ovwrt_) - - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_add_) - - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - call psb_errpush(130,name) - goto 9999 - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - end select - - - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - case(1) ! Col major order - - call msort_up(nza,a%ia2(1),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nza,a%aspk,a%ia1,a%ia2,iaux) - i = 1 - j = i - do while (i <= nza) - do while ((a%ia2(j) == a%ia2(i))) - j = j+1 - if (j > nza) exit - enddo - nzl = j - i - call msort_up(nzl,a%ia1(i),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,a%aspk(i:i+nzl-1),& - & a%ia1(i:i+nzl-1),a%ia2(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = a%ia1(i) - icl = a%ia2(i) - j = 1 - - - select case(dupl_) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - call psb_errpush(130,name) - goto 9999 - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - end select - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - case default - write(debug_unit,*) trim(name),': unknown direction ',idir_ - end select - - call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info) - call psb_sp_setifld(i,psb_nnz_,a,info) - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info) - - deallocate(iaux) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_sfixcoo diff --git a/base/serial/psb_sgelp.f90 b/base/serial/psb_sgelp.f90 deleted file mode 100644 index 1e59b6f90..000000000 --- a/base/serial/psb_sgelp.f90 +++ /dev/null @@ -1,252 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sgelp.f90 -! -! -! Subroutine: psb_sgelp -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:,:). -! info - integer. Return code. -subroutine psb_sgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_sgelp - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_spk_), intent(inout) :: x(:,:) - integer, intent(in) :: iperm(:) - integer, intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer :: ictxt - real(psb_spk_),allocatable :: dtemp(:) - integer :: int_err(5), i1sz, i2sz, err_act - integer, allocatable :: itemp(:) - real(psb_spk_),parameter :: one=1 - integer :: debug_level, debug_unit - - interface sgelp - subroutine sgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - real(psb_spk_), intent(inout) :: b(ldb,*), work(*) - integer, intent(in) :: p(*) - end subroutine sgelp - end interface - - character(len=20) :: name, ch_err - name = 'psb_sgelp' - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz,i2sz - - allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - - call sgelp(trans,i1sz,i2sz,itemp,x,i1sz,dtemp,i1sz,info) - if(info /= 0) then - info=4010 - ch_err='sgelp' - call psb_errpush(info,name,a_err=ch_err) - end if - - deallocate(dtemp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_sgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! -! Subroutine: psb_sgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_sgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_sgelpv - use psb_const_mod - use psb_error_mod - implicit none - - real(psb_spk_), intent(inout) :: x(:) - integer, intent(in) :: iperm(:) - integer, intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer :: ictxt - integer :: int_err(5), i1sz, err_act - real(psb_spk_),allocatable :: dtemp(:) - integer, allocatable :: itemp(:) - real(psb_spk_),parameter :: one=1 - integer :: debug_level, debug_unit - - interface sgelp - subroutine sgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - real(psb_spk_), intent(inout) :: b(*), work(*) - integer, intent(in) :: p(*) - end subroutine sgelp - end interface - - character(len=20) :: name, ch_err - name = 'psb_sgelpv' - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - i1sz = size(x) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': size',i1sz - allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - call sgelp(trans,i1sz,1,itemp,x,i1sz,dtemp,i1sz,info) - if(info /= 0) then - info=4010 - ch_err='sgelp' - call psb_errpush(info,name,a_err=ch_err) - end if - - deallocate(dtemp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_sgelpv - diff --git a/base/serial/psb_sipcoo2csc.f90 b/base/serial/psb_sipcoo2csc.f90 deleted file mode 100644 index c51ac5b0e..000000000 --- a/base/serial/psb_sipcoo2csc.f90 +++ /dev/null @@ -1,221 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sipcoo2csc.f90 -! Subroutine: -! Arguments: - -subroutine psb_sipcoo2csc(a,info,clshr) - use psb_spmat_type - use psb_const_mod - use psb_serial_mod, psb_protect_name => psb_sipcoo2csc - use psb_error_mod - use psb_string_mod - use psb_realloc_mod - implicit none - - !....Parameters... - Type(psb_sspmat_type), intent(inout) :: A - Integer, intent(out) :: info - logical, optional :: clshr - - integer, allocatable :: iaux(:), itemp(:) - !locals - logical :: clshr_ - Integer :: nza, i,j, idl,err_act,nc,icl - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name - - name='psb_ipcoo2csc' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) write(debug_unit,*) & - & trim(name),': start',a%fida,a%m - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) trim(name),' Invalid input ',a%fida - info = -1 - call psb_errpush(info,name) - goto 9999 - end if - if (present(clshr)) then - clshr_ = clshr - else - clshr_ = .false. - end if - - call psb_fixcoo(a,info,idir=1) - if (info == 0) then - nc = a%k - nza = a%infoa(psb_nnz_) - allocate(iaux(max(nc+1,1)),stat=info) - end if - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nc+1,1),0,0,0,0/)) - goto 9999 - end if - if(debug_level >= psb_debug_serial_) write(debug_unit,*) trim(name),& - & ': out of fixcoo',nza,nc,size(a%ia2),size(iaux) - - call psb_move_alloc(a%ia2,itemp,info) - if (info == 0) call psb_move_alloc(iaux,a%ia2,info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_move_alloc') - goto 9999 - end if - - ! - ! This routine can be used in two modes: - ! 1. Normal: just look at the col indices and trust them. This - ! implies putting in empty cols where needed. In this case you - ! can get in trouble if A%M < A%IA1(NZA) - ! 2. Shrink mode: disregard the actual value of the col indices, - ! just treat them as ident markers. In this case you can get in - ! trouble when the number of distinct col indices is greater - ! than A%M - ! - ! - - a%ia2(1) = 1 - - if (nza <= 0) then - do i=1,nc - a%ia2(i+1) = a%ia2(i) - end do - else - - if (clshr_) then - - j = 1 - i = 1 - icl = itemp(j) - - do j=1, nza - if (itemp(j) /= icl) then - a%ia2(i+1) = j - icl = itemp(j) - i = i + 1 - if (i>nc) then - write(debug_unit,*) trim(name),': CLSHR=.true. : ',& - & i, nc,' Expect trouble!' - exit - end if - endif - enddo -! write(debug_unit,*) 'Exit from loop',j,nza,i - do - if (i>=nc+1) exit - a%ia2(i+1) = j - i = i + 1 - end do - - else - - if (nc < itemp(nza)) then - write(debug_unit,*) trim(name),': CLSHR=.false. : ',& - &nc,itemp(nza),' Expect trouble!' - end if - - - j = 1 - i = 1 - icl = itemp(j) - - outer: do - inner: do - if (i >= icl) exit inner - if (i>nc) then - write(debug_unit,*) trim(name),& - & 'strange situation: i>nc ',i,nc,j,nza,icl,idl - exit outer - end if - a%ia2(i+1) = a%ia2(i) - i = i + 1 - end do inner - j = j + 1 - if (j > nza) exit - if (itemp(j) /= icl) then - if (i>nc) then - write(debug_unit,*) trim(name), & - &'Strange situation: ',i,nc,size(a%ia2),& - & nza,j,itemp(j) - end if - a%ia2(i+1) = j - icl = itemp(j) - i = i + 1 - endif - if (i>nc) exit - enddo outer - ! - ! Cleanup empty cols at the end - ! - if (j /= (nza+1)) then - write(debug_unit,*) trim(name),': Problem from loop :',j,nza,itemp(j) - endif - do - if (i>nc) exit - a%ia2(i+1) = j - i = i + 1 - end do - - endif - - end if - -!!$ write(debug_unit,*) 'IPcoo2csc end loop ',i,nc,a%ia2(nc+1),nza - a%fida='CSC' - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp,stat=info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='deallocate') - goto 9999 - end if - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_sipcoo2csc diff --git a/base/serial/psb_sipcoo2csr.f90 b/base/serial/psb_sipcoo2csr.f90 deleted file mode 100644 index c532c25bc..000000000 --- a/base/serial/psb_sipcoo2csr.f90 +++ /dev/null @@ -1,213 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sipcoo2csr.f90 -! Subroutine: -! Arguments: - -subroutine psb_sipcoo2csr(a,info,rwshr) - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_serial_mod, psb_protect_name => psb_sipcoo2csr - use psb_error_mod - use psb_string_mod - implicit none - - !....Parameters... - Type(psb_sspmat_type), intent(inout) :: A - Integer, intent(out) :: info - logical, optional :: rwshr - - integer, allocatable :: iaux(:), itemp(:) - !locals - logical :: rwshr_ - Integer :: nza, nr, i,j,irw, idl,err_act - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name - - name='psb_ipcoo2csr' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': start',a%fida,a%m - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) trim(name),': Invalid input ',a%fida - info = -1 - call psb_errpush(info,name) - goto 9999 - end if - if (present(rwshr)) then - rwshr_ = rwshr - else - rwshr_ = .false. - end if - - call psb_fixcoo(a,info) - nr = a%m - nza = a%infoa(psb_nnz_) - allocate(iaux(max(nr+1,1)),stat=info) - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nr+1,1),0,0,0,0/)) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & ': out of fixcoo',nza,nr,size(a%ia2),size(iaux) - - call psb_move_alloc(a%ia1,itemp,info) - call psb_move_alloc(a%ia2,a%ia1,info) - call psb_move_alloc(iaux,a%ia2,info) - - ! - ! This routine can be used in two modes: - ! 1. Normal: just look at the row indices and trust them. This - ! implies putting in empty rows where needed. In this case you - ! can get in trouble if A%M < A%IA1(NZA) - ! 2. Shrink mode: disregard the actual value of the row indices, - ! just treat them as ident markers. In this case you can get in - ! trouble when the number of distinct row indices is greater - ! than A%M - ! - ! - - a%ia2(1) = 1 - - if (nza <= 0) then - do i=1,nr - a%ia2(i+1) = a%ia2(i) - end do - else - - if (rwshr_) then - - - j = 1 - i = 1 - irw = itemp(j) - - do j=1, nza - if (itemp(j) /= irw) then - a%ia2(i+1) = j - irw = itemp(j) - i = i + 1 - if (i>nr) then - write(debug_unit,*) trim(name),': RWSHR=.true. : ',& - & i, nr,' Expect trouble!' - exit - end if - endif - enddo - do - if (i>=nr+1) exit - a%ia2(i+1) = j - i = i + 1 - end do - - else - - if (nr < itemp(nza)) then - write(debug_unit,*) trim(name),': RWSHR=.false. : ',& - &nr,itemp(nza),' Expect trouble!' - info = 12 - end if - - - j = 1 - i = 1 - irw = itemp(j) - - outer: do - inner: do - if (i >= irw) exit inner - if (i>nr) then - write(debug_unit,*) trim(name),& - & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl - exit outer - end if - a%ia2(i+1) = a%ia2(i) - i = i + 1 - end do inner - j = j + 1 - if (j > nza) exit - if (itemp(j) /= irw) then - a%ia2(i+1) = j - irw = itemp(j) - i = i + 1 - endif - if (i>nr) exit - enddo outer - ! - ! Cleanup empty rows at the end - ! - if (j /= (nza+1)) then - write(debug_unit,*) trim(name),': Problem from loop :',j,nza - info = 13 - endif - do - if (i>nr) exit - a%ia2(i+1) = j - i = i + 1 - end do - - endif - - end if - - a%fida='CSR' - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp,stat=info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='deallocate') - goto 9999 - end if - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_sipcoo2csr diff --git a/base/serial/psb_sipcsr2coo.f90 b/base/serial/psb_sipcsr2coo.f90 deleted file mode 100644 index d5a7ba592..000000000 --- a/base/serial/psb_sipcsr2coo.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sipcsr2coo.f90 -! Subroutine: -! Arguments: - -Subroutine psb_sipcsr2coo(a,info) - use psb_spmat_type - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_realloc_mod - use psb_serial_mod, psb_protect_name => psb_sipcsr2coo - implicit none - - !....Parameters... - Type(psb_sspmat_type), intent(inout) :: A - Integer, intent(out) :: info - - !locals - Integer :: nza, nr - integer :: i,j,err_act - integer, allocatable :: iaux(:), itemp(:) - character(len=20) :: name='psb_sipcsr2coo' - - info = 0 - call psb_erractionsave(err_act) - - if (psb_toupper(a%fida) /= 'CSR') then - info = 5 - call psb_errpush(info,name) - goto 9999 - end if - - nr = a%m - nza = a%ia2(nr+1) - 1 - allocate(iaux(max(nza,1)),stat=info) - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nza,1),0,0,0,0/)) - goto 9999 - end if - - call psb_move_alloc(a%ia2,itemp,info) - call psb_move_alloc(a%ia1,a%ia2,info) - call psb_move_alloc(iaux,a%ia1,info) - - do i=1, nr - do j=itemp(i),itemp(i+1)-1 - a%ia1(j) = i - end do - end do - - a%fida='COO' - a%infoa(psb_nnz_) = nza - a%infoa(psb_srtd_) = psb_isrtdcoo_ - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp) - call psb_fixcoo(a,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_sipcsr2coo diff --git a/base/serial/psb_sneigh.f90 b/base/serial/psb_sneigh.f90 deleted file mode 100644 index ed7490e4e..000000000 --- a/base/serial/psb_sneigh.f90 +++ /dev/null @@ -1,121 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sneigh.f90 -! Subroutine: -! Arguments: - -subroutine psb_sneigh(a,idx,neigh,n,info,lev) - - use psb_realloc_mod - use psb_const_mod - use psb_spmat_type - use psb_serial_mod, psb_protect_name => psb_sneigh - implicit none - - - type(psb_sspmat_type), intent(in) :: a ! the sparse matrix - integer, intent(in) :: idx ! the index whose neighbours we want to find - integer, intent(out) :: n, info ! the number of neighbours and the info - integer, allocatable :: neigh(:) ! the neighbours - integer, optional, intent(in) :: lev ! level of neighbours to find - - integer :: lev_, i, nl, ifl,ill,& - & n1, err_act, nn, nidx,ntl - character(len=20) :: name - integer, allocatable :: ia(:), ja(:) - real(psb_spk_), allocatable :: val(:) - - name='psb_sneigh' - info = 0 - call psb_erractionsave(err_act) - - n = 0 - info = 0 - if(present(lev)) then - lev_=lev - else - lev_=1 - end if - - call psb_sp_getrow(idx,a,n,ia,ja,val,info) - if (info == 0) call psb_realloc(n,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(1:n) = ja(1:n) - ifl = 1 - ill = n - - - do nl = 2, lev_ - n1 = ill - ifl + 1 - call psb_ensure_size(ill+n1*n1,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - ntl = 0 - do i=ifl,ill - nidx=neigh(i) - if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then - call psb_sp_getrow(nidx,a,nn,ia,ja,val,info) - if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) - ntl = ntl+nn - end if - end do - call psb_msort_unique(neigh(ill+1:ill+ntl),nn) - ifl = ill + 1 - ill = ill + nn - end do - call imsru(ill,neigh,psb_sort_up_,nn) - n = nn - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_sneigh - diff --git a/base/serial/psb_sspclip.f90 b/base/serial/psb_sspclip.f90 deleted file mode 100644 index d749da381..000000000 --- a/base/serial/psb_sspclip.f90 +++ /dev/null @@ -1,157 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sspclip.f90 -! Subroutine: psb_sspclip -! Creates a "clipped" copy of input matrix A. Output is always in COO. -! Arguments: - -!***************************************************************************** -!* * -!***************************************************************************** -subroutine psb_sspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_sspclip - implicit none - type(psb_sspmat_type), intent(in) :: a - type(psb_sspmat_type), intent(out) :: b - integer, intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - integer :: err_act - character(len=20) :: name - integer :: imin_,imax_,jmin_,jmax_ - logical :: rscale_,cscale_ - integer :: sizeb, nzb, mb, kb, ifst, ilst, nrt, nzt, i, j - integer, parameter :: irbk=40 - - name='psb_ssp_clip' - info = 0 - call psb_erractionsave(err_act) - call psb_set_erraction(0) - - call psb_nullify_sp(b) - - - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - endif - if (present(imax)) then - imax_ = imax - else - imax_ = a%m - endif - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%k - endif - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - endif - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - endif - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%m ! Should this be imax_ ?? - endif - if (cscale_) then - kb = jmax_ - jmin_ +1 - else - kb = a%k ! Should this be jmax_ ?? - endif - - - sizeb = psb_sp_get_nnzeros(a) - call psb_sp_all(mb,kb,b,sizeb,info) - b%fida = 'COO' - b%descra = a%descra - nzb = 0 - do i=imin_, imax_, irbk - nrt = min(irbk,imax_-i+1) - ifst = i - ilst = ifst + nrt - 1 - call psb_sp_getrow(ifst,a,nzt,b%ia1,b%ia2,b%aspk,info,& - & lrw=ilst, append=.true.,nzin=nzb) - do j=nzb+1,nzb+nzt - if ((jmin_ <= b%ia2(j)).and.(b%ia2(j) <= jmax_)) then - nzb = nzb + 1 - b%aspk(nzb) = b%aspk(j) - b%ia1(nzb) = b%ia1(j) - b%ia2(nzb) = b%ia2(j) - end if - end do - - end do - b%infoa(psb_nnz_) = nzb - - if (rscale_) then - do i=1, nzb - b%ia1(i) = b%ia1(i) - imin_ + 1 - end do - end if - if (cscale_) then - do i=1, nzb - b%ia2(i) = b%ia2(i) - jmin_ + 1 - end do - end if - call psb_fixcoo(b,info) - call psb_sp_trim(b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_sspclip - diff --git a/base/serial/psb_sspcnv.f90 b/base/serial/psb_sspcnv.f90 deleted file mode 100644 index 5291d9816..000000000 --- a/base/serial/psb_sspcnv.f90 +++ /dev/null @@ -1,572 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sspcnv.f90 -! -! Subroutine: psb_sspcnv2 -! This subroutine converts the storage format of a matrix. -! -! Arguments: -! -! a - type(psb_spmat_type), input The input matrix to be converted. -! b - type(psb_spmat_type), output The assembled output matrix. -! info - integer. Return code -! afmt - character, optional The desired storage format -! -subroutine psb_sspcnv2(a, b,info,afmt,upd,dupl) - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_sspcnv2 - implicit none - !....Parameters... - Type(psb_sspmat_type), intent(in) :: A - Type(psb_sspmat_type), intent(out) :: B - Integer, intent(out) :: info - Integer, intent(in), optional :: upd,dupl - character(len=*), optional, intent(in) :: afmt - - !...Locals... - real(psb_spk_) :: d(1) - real(psb_spk_), allocatable :: work(:) - type(psb_sspmat_type) :: temp_a - Integer :: nzr, ntry, ifc_, ia1_size,& - & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ - integer :: err_act - character :: check_,trans_,unitd_ - character(len=5) :: afmt_ - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - - name='psb_spcnv2' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ntry=0 - - ifc_ = 2 - - check_ = 'N' - trans_ = 'N' - unitd_ = 'U' - allocate(work(max(size(a%ia1),size(a%ia2))+a%m+1000),stat=info) - - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,b,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,b,info) - end if - if (present(afmt)) then - afmt_ = psb_toupper(afmt) - else - afmt_ = psb_fidef_ - end if - - upd_ = psb_sp_getifld(psb_upd_,b,info) - select case(upd_) - case(psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,b,info) - end select - - dupl_ = psb_sp_getifld(psb_dupl_,b,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,b,info) - end select - - ! ...matrix conversion... - b%m=a%m - b%k=a%k - b%fida=psb_toupper(afmt_) - size_req = psb_sp_get_nnzeros(a) - ! - n_row=b%m - n_col=b%k - call psb_cest(afmt_,n_row,n_col,size_req,& - & ia1_size, ia2_size, aspk_size, upd_,info) - b%fida=afmt_ - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_cest' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - if (.not.allocated(b%aspk).or.& - &.not.allocated(b%ia1).or.& - &.not.allocated(b%ia2).or.& - &.not.allocated(b%pl).or.& - &.not.allocated(b%pr)) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - else if ((size(b%aspk) < aspk_size) .or.& - &(size(b%ia1) < ia1_size) .or.& - &(size(b%ia2) < ia2_size) .or.& - &(size(b%pl) < b%m) .or.& - &(size(b%pr) < b%k )) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - endif - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - b%pl(:) = 0 - b%pr(:) = 0 - - b%descra = a%descra - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': size_req 1:',& - & size_req, trans_,upd_,dupl_,b%fida,b%descra - - select case (psb_toupper(a%fida)) - - case ('CSR') - - select case (psb_toupper(b%fida)) - - case ('CSR') - - call scrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - - if (info/=0) then - info=4010 - ch_err='scrcr' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case ('JAD') - - !...converting to JAD - !...output matrix may not be big enough - do - - call scrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='scrjd') - goto 9999 - endif - - ntry = ntry + 1 - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),' On out from scrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(debug_unit,*) trim(name),& - & ' Tried reallocating for SCRJAD for ',maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - call psb_cest(afmt_,n_row,n_col,nzr,& - & ia1_size, ia2_size, aspk_size, upd_,info) - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - if (info/=0) then - call psb_errpush(info,name) - goto 9999 - end if - - case ('COO') - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),' Calling CRCO ',a%descra - call scrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrco') - goto 9999 - end if - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - case ('COO','COI') - - select case (psb_toupper(b%fida)) - - case ('CSR') - - call scocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='scocr') - goto 9999 - end if - - case ('JAD') - - call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - temp_a%m = a%m - temp_a%k = a%k - temp_a%infoa=b%infoa - !...Dirty trick: converting to CSR and then to JAD - - call scocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, & - & size(temp_a%aspk), size(temp_a%ia1),& - & size(temp_a%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='scocr') - goto 9999 - end if - - do - call scrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, & - & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, & - & size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info/=0) then - call psb_errpush(4010,name,a_err='scrjd') - goto 9999 - end if - - ntry = ntry + 1 - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),' On out from scrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(debug_unit,*) trim(name),' Tried reallocating for sCRJAD for ',& - & maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_sp_reall(b,nzr,info,ifc=ifc_) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - case ('COO') - - call scoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - if (info/=0) then - call psb_errpush(4010,name,a_err='scoco') - goto 9999 - end if - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - end select - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) then - call psb_sp_trim(b,info) - end if - - - call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_sspcnv2 - - -! -! Subroutine: psb_sspcnv1 -! This subroutine converts in place the storage format of a matrix. -! -! Arguments: -! -! a - type(psb_spmat_type), inout The input matrix to be converted. -! info - integer. Return code -! afmt - character, optional The desired storage format -! -subroutine psb_sspcnv1(a, info, afmt, upd, dupl) - - use psb_spmat_type - use psb_regen_mod - use psb_serial_mod, psb_protect_name => psb_sspcnv1 - use psb_const_mod - use psi_mod - use psb_error_mod - use psb_string_mod - !use psb_penv_mod - - implicit none - - - !...Parameters.... - type(psb_sspmat_type), intent (inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: afmt - - integer :: int_err(5) - type(psb_sspmat_type) :: atemp - integer :: err_act - integer :: spstate - integer :: upd_, dupl_ - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - logical :: inplace - - info = 0 - int_err(1)=0 - name = 'psb_spcnv1' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,a,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,a,info) - end if - - upd_ = psb_sp_getifld(psb_upd_,a,info) - select case(upd_) - case(psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,a,info) - end select - - dupl_ = psb_sp_getifld(psb_dupl_,a,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,a,info) - end select - - - spstate = psb_sp_getifld(psb_state_,a,info) - if (info /= 0) then - goto 9999 - endif - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': Sparse matrix state:',& - & spstate,psb_spmat_bld_,psb_spmat_upd_ - if (spstate /= psb_spmat_upd_) then - ! Should we first figure out if we can do it in place? - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Update:',upd_,psb_upd_srch_,psb_upd_perm_ - inplace = .false. - if (upd_ == psb_upd_srch_) then - if (present(afmt)) then - select case (psb_toupper(a%fida)) - case('COO') - select case(psb_toupper(afmt)) - case('COO') - call psb_fixcoo(a,info) - inplace = .true. - case('CSR') - call psb_ipcoo2csr(a,info) - inplace = .true. - case('CSC') - call psb_ipcoo2csc(a,info) - inplace = .true. - end select - case('CSR') - select case(psb_toupper(afmt)) - case('COO') - call psb_ipcsr2coo(a,info) - inplace = .true. - end select - end select - end if - if (inplace) then - if (info == 0) call psb_sp_trim(a,info) - if (info /= 0) then - info=4010 - ch_err='inplace cnv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - call psb_erractionrestore(err_act) - return - end if - end if - - call psb_sp_clone(a,atemp,info) - if(info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_clone' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - ! convert to user requested format after the temp copy - end if - - ! Do the real conversion into the requested storage format - ! result is put in A - call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit, *) trim(name),& - & ': From SPCNV',info,' ',a%fida - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - call psb_sp_free(atemp,info) - - else if (spstate == psb_spmat_upd_) then - ! - ! Second case: we come from an update loop. - ! - select case(psb_toupper(a%fida)) - case('CSR') - call csr_regen(a,info) - case ('COO','COI') - call coo_regen(a,info) - case('JAD') - call jad_regen(a,info) - case default - info=136 - ch_err=a%fida - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (info /= psb_no_err_) then - info = 4010 - ch_err='xx_regen' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - else - - info = 600 - call psb_errpush(info,name) - goto 9999 - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ - - endif - - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_sspcnv1 diff --git a/base/serial/psb_sspgetrow.f90 b/base/serial/psb_sspgetrow.f90 deleted file mode 100644 index e63c8f9be..000000000 --- a/base/serial/psb_sspgetrow.f90 +++ /dev/null @@ -1,130 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sspgetrow.f90 -! Subroutine: psb_sspgetrow -! Gets one or more rows from a sparse matrix. -! Arguments: -! irw - integer, input The row to be extracted -! a - type(psb_sspmat_type),input The sparse matrix -! nz - integer, output The number of entries -! ia(:) - integer, allocatable, inout The output row indices -! ja(:) - integer, allocatable, inout The output col indices -! val(:) - real, allocatable,inout The coefficients -! info - integer, output Error code -! iren(:) - integer, input,optional Renumbering of indices -! lrw - integer, input,optional Extract rows irw:lrw, default lrw=irw -! append - logical, input,optional Should we append to already existing -! partial output? -! nzin - integer, input, optional If appending, how many entries were already -! occupied. -! -subroutine psb_sspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) - ! Output is always in COO format - use psb_spmat_type - use psb_const_mod - use psb_getrow_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_sspgetrow - implicit none - - type(psb_sspmat_type), intent(in) :: a - integer, intent(in) :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - real(psb_spk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: lrw, nzin - - logical :: append_ - integer :: nzin_, lrw_, irw_, err_act - character(len=20) :: name, ch_err - - name='psb_spgetrow' - info = 0 - - call psb_erractionsave(err_act) - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_=append - else - append_=.false. - endif - - - if ((append_).and.(present(nzin))) then - nzin_ = nzin - else - nzin_ = 0 - endif - - select case (psb_tolower(a%fida)) - case ('csr') - call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case ('coo') - call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case ('jad') - call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (info /= 0) goto 9999 -!!$ call psb_erractionrestore(err_act) - return - -9999 continue -!!$ call psb_erractionrestore(err_act) - call psb_erractionsave(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_sspgetrow - diff --git a/base/serial/psb_sspgtblk.f90 b/base/serial/psb_sspgtblk.f90 deleted file mode 100644 index aed1617ce..000000000 --- a/base/serial/psb_sspgtblk.f90 +++ /dev/null @@ -1,114 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sspgtblk.f90 -! Subroutine: psb_sspgtblk -! Gets one or more rows from a sparse matrix. -! Arguments: -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, * -!* * -!***************************************************************************** -subroutine psb_sspgtblk(irw,a,b,info,append,iren,lrw,srt) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_sspgtblk - implicit none - - type(psb_sspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_sspmat_type), intent(inout) :: b - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - logical, intent(in), optional :: srt - - logical :: append_,srt_ - integer :: nz,nzb, lrw_, irw_ - character(len=20) :: name - - name='psb_spgtblk' - info = 0 - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_ = append - else - append_ = .false. - endif - - if (present(srt)) then - srt_ = srt - else - srt_ = .true. - endif - - - if (append_) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - b%m = 0 - b%k = 0 - b%descra = a%descra - endif - b%fida = 'COO' - - call psb_sp_getrow(irw,a,nz,b%ia1,b%ia2,b%aspk,info,iren=iren,& - & lrw=lrw_,append=append_,nzin=nzb) - if (info == 0) call psb_ensure_size(1,b%pl,info) - if (info == 0) call psb_ensure_size(1,b%pr,info) - if (info /= 0) return - b%pl = 0 - b%pr = 0 - b%infoa(psb_nnz_) = nzb+nz - b%m = b%m+lrw_-irw+1 - b%k = max(b%k,a%k) - if (srt_) call psb_fixcoo(b,info) - return - -end subroutine psb_sspgtblk - diff --git a/base/serial/psb_sspgtdiag.f90 b/base/serial/psb_sspgtdiag.f90 deleted file mode 100644 index bc31d9ce8..000000000 --- a/base/serial/psb_sspgtdiag.f90 +++ /dev/null @@ -1,123 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sspgtdiag.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* * -!***************************************************************************** -subroutine psb_sspgtdiag(a,d,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_serial_mod, psb_protect_name => psb_sspgtdiag - implicit none - - type(psb_sspmat_type), intent(in) :: a - real(psb_spk_), intent(inout) :: d(:) - integer, intent(out) :: info - - type(psb_sspmat_type) :: tmpa - integer :: i,j, err_act, ii, rng, irb, nrb - character(len=20) :: name, ch_err - - name='psb_sspgtdiag' - info = 0 - call psb_erractionsave(err_act) - - if (size(d) < min(a%k,a%m)) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - d(:) = 0.d0 - if (a%fida == 'CSR') then - - do i=1, min(a%m,a%k) - do j=a%ia2(i),a%ia2(i+1)-1 - if (a%ia1(j) == i) then - d(i) = a%aspk(j) - end if - end do - end do - - else if (a%fida == 'COO') then - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - if ((j==a%ia2(i)).and.(j <= min(a%k,a%m)) .and.(j>0)) then - d(j) = a%aspk(i) - endif - enddo - - else if (a%fida == 'JAD') then - - rng=min(a%m,a%k) - nrb=16 - do i=1, rng, nrb - irb=min(i+nrb-1,rng) - call psb_sp_getblk(i,a,tmpa,info,lrw=irb) - if(info /= 0) then - info=4010 - ch_err='psb_sp_getblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do ii=1,tmpa%infoa(psb_nnz_) - j=tmpa%ia1(ii) - if ((j==tmpa%ia2(ii)).and.(j <= rng) .and.(j>0)) then - d(j) = tmpa%aspk(ii) - endif - enddo - - end do - - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_sspgtdiag - diff --git a/base/serial/psb_sspscal.f90 b/base/serial/psb_sspscal.f90 deleted file mode 100644 index 95aa91afa..000000000 --- a/base/serial/psb_sspscal.f90 +++ /dev/null @@ -1,159 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_sspscal.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* * -!***************************************************************************** -subroutine psb_sspscal(a,d,info) - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - - type(psb_sspmat_type), intent(inout) :: a - integer, intent(out) :: info - real(psb_spk_), intent(in) :: d(:) - - integer :: i,j,err_act - character(len=20) :: name, ch_err - - name='psb_sspscal' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_toupper(a%fida(1:3))) - case ('CSR') - - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - a%aspk(j) = a%aspk(j) * d(i) - end do - end do - - case ('COO') - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - a%aspk(i) = a%aspk(i) * d(j) - enddo - - case ('JAD') - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_sspscal - -subroutine psb_sspscals(a,d,info) - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - - type(psb_sspmat_type), intent(inout) :: a - integer, intent(out) :: info - real(psb_spk_), intent(in) :: d - - integer :: i,j,err_act - character(len=20) :: name, ch_err - - name='psb_sspscal' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_toupper(a%fida(1:3))) - case ('CSR') - - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - a%aspk(j) = a%aspk(j) * d - end do - end do - - case ('COO') - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - a%aspk(i) = a%aspk(i) * d - enddo - - case ('JAD') - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_sspscals - diff --git a/base/serial/psb_stransp.f90 b/base/serial/psb_stransp.f90 deleted file mode 100644 index 591129103..000000000 --- a/base/serial/psb_stransp.f90 +++ /dev/null @@ -1,121 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_stransp.f90 -! Subroutine: -! Arguments: - -subroutine psb_stransp(a,b,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_stransp - implicit none - - type(psb_sspmat_type), intent(in) :: a - type(psb_sspmat_type), intent(out) :: b - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer ::c_, info - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_nullify_sp(b) - - call psb_spcnv(a,b,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(b%ia1,itmp,info) - call psb_move_alloc(b%ia2,b%ia1,info) - call psb_move_alloc(itmp,b%ia2,info) - - b%m = a%k - b%k = a%m - call psb_spcnv(b,info,afmt=fmt_) - - return -end subroutine psb_stransp - -subroutine psb_stransp1(a,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_stransp1 - implicit none - - type(psb_sspmat_type), intent(inout) :: a - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer ::c_, info - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_spcnv(a,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(a%ia1,itmp,info) - call psb_move_alloc(a%ia2,a%ia1,info) - call psb_move_alloc(itmp,a%ia2,info) - - call psb_spcnv(a,info,afmt=fmt_) - - return -end subroutine psb_stransp1 diff --git a/base/serial/psb_update_mod.f90 b/base/serial/psb_update_mod.f90 deleted file mode 100644 index 9fdacd2c7..000000000 --- a/base/serial/psb_update_mod.f90 +++ /dev/null @@ -1,2880 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -module psb_update_mod - - interface psb_srch_upd - module procedure psb_c_srch_upd, psb_z_srch_upd - end interface - - interface coo_srch_upd - module procedure c_coo_srch_upd, z_coo_srch_upd - end interface - - interface csr_srch_upd - module procedure c_csr_srch_upd, z_csr_srch_upd - end interface - - interface jad_srch_upd - module procedure c_jad_srch_upd, z_jad_srch_upd - end interface - -contains - -!!$ -!!$ subroutine psb_s_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_realloc_mod -!!$ use psb_string_mod -!!$ use psb_serial_mod -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(inout) :: a -!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl -!!$ integer, intent(in) :: ia(:),ja(:) -!!$ integer, intent(inout) :: nza -!!$ real(psb_spk_), intent(in) :: val(:) -!!$ integer, intent(out) :: info -!!$ integer, intent(in), optional :: ng,gtl(:) -!!$ -!!$ info = 0 -!!$ -!!$ if (present(gtl)) then -!!$ if (.not.present(ng)) then -!!$ info = -1 -!!$ return -!!$ endif -!!$ end if -!!$ select case(psb_tolower(a%fida)) -!!$ case ('csr') -!!$ call csr_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ case ('coo') -!!$ call coo_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ case ('jad') -!!$ call jad_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ case default -!!$ -!!$ info = -9 -!!$ -!!$ end select -!!$ -!!$ end subroutine psb_s_srch_upd -!!$ -!!$ subroutine psb_d_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_realloc_mod -!!$ use psb_string_mod -!!$ use psb_serial_mod -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(inout) :: a -!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl -!!$ integer, intent(in) :: ia(:),ja(:) -!!$ integer, intent(inout) :: nza -!!$ real(psb_dpk_), intent(in) :: val(:) -!!$ integer, intent(out) :: info -!!$ integer, intent(in), optional :: ng,gtl(:) -!!$ -!!$ info = 0 -!!$ -!!$ if (present(gtl)) then -!!$ if (.not.present(ng)) then -!!$ info = -1 -!!$ return -!!$ endif -!!$ end if -!!$ select case(psb_tolower(a%fida)) -!!$ case ('csr') -!!$ call csr_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ case ('coo') -!!$ call coo_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ case ('jad') -!!$ call jad_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ case default -!!$ -!!$ info = -9 -!!$ -!!$ end select -!!$ -!!$ end subroutine psb_d_srch_upd - - subroutine psb_c_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_serial_mod - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_spk_), intent(in) :: val(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - - info = 0 - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - - select case(psb_toupper(a%fida)) - case ('CSR') -!!$ write(0,*) 'Calling csr_srch_upd' - call csr_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ write(0,*) 'From csr_srch_upd:',info - case ('COO') - call coo_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - case default - - info = -9 - - end select - else - select case(psb_toupper(a%fida)) - case ('CSR') -!!$ write(0,*) 'Calling csr_srch_upd' - call csr_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) -!!$ write(0,*) 'From csr_srch_upd:',info - case ('COO') - call coo_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) - - case default - - info = -9 - - end select - end if - - end subroutine psb_c_srch_upd - - - subroutine psb_z_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_serial_mod - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - - info = 0 - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - - select case(psb_toupper(a%fida)) - case ('CSR') -!!$ write(0,*) 'Calling csr_srch_upd' - call csr_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ write(0,*) 'From csr_srch_upd:',info - case ('COO') - call coo_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - case default - - info = -9 - - end select - else - select case(psb_toupper(a%fida)) - case ('CSR') -!!$ write(0,*) 'Calling csr_srch_upd' - call csr_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) -!!$ write(0,*) 'From csr_srch_upd:',info - case ('COO') - call coo_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) - - case default - - info = -9 - - end select - end if - - end subroutine psb_z_srch_upd - -!!$ -!!$ subroutine s_csr_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_realloc_mod -!!$ use psb_string_mod -!!$ use psb_serial_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(inout) :: a -!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl -!!$ integer, intent(in) :: ia(:),ja(:) -!!$ integer, intent(inout) :: nza -!!$ real(psb_spk_), intent(in) :: val(:) -!!$ integer, intent(out) :: info -!!$ integer, intent(in), optional :: ng,gtl(:) -!!$ -!!$ integer :: debug_level, debug_unit -!!$ character(len=20) :: name='s_csr_srch_upd' -!!$ integer :: i,ir,ic, ilr, ilc, ip, & -!!$ & i1,i2,nc,lb,ub,m,dupl -!!$ -!!$ info = 0 -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ dupl = psb_sp_getifld(psb_dupl_,a,info) -!!$ -!!$ if (present(gtl)) then -!!$ if (.not.present(ng)) then -!!$ info = -1 -!!$ return -!!$ endif -!!$ -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ ! Overwrite. -!!$ ! Cannot test for error, should have been caught earlier. -!!$ -!!$ ilr = -1 -!!$ ilc = -1 -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ ic = gtl(ic) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ i1 = a%ia2(ir) -!!$ i2 = a%ia2(ir+1) -!!$ nc=i2-i1 -!!$ -!!$ ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = val(i) -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Was searching ',ic,' in: ',i1,i2,& -!!$ & ' : ',a%ia1(i1:i2-1) -!!$ info = i -!!$ return -!!$ end if -!!$ -!!$ else -!!$ -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case(psb_dupl_add_) -!!$ ! Add -!!$ ilr = -1 -!!$ ilc = -1 -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ ic = gtl(ic) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ i1 = a%ia2(ir) -!!$ i2 = a%ia2(ir+1) -!!$ nc = i2-i1 -!!$ ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Was searching ',ic,' in: ',i1,i2,& -!!$ & ' : ',a%ia1(i1:i2-1) -!!$ info = i -!!$ return -!!$ end if -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case default -!!$ info = -3 -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Duplicate handling: ',dupl -!!$ end select -!!$ -!!$ else -!!$ -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ ! Overwrite. -!!$ ! Cannot test for error, should have been caught earlier. -!!$ -!!$ ilr = -1 -!!$ ilc = -1 -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ -!!$ i1 = a%ia2(ir) -!!$ i2 = a%ia2(ir+1) -!!$ nc=i2-i1 -!!$ -!!$ ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = val(i) -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Was searching ',ic,' in: ',i1,i2,& -!!$ & ' : ',a%ia1(i1:i2-1) -!!$ info = i -!!$ return -!!$ end if -!!$ -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ -!!$ end do -!!$ -!!$ case(psb_dupl_add_) -!!$ ! Add -!!$ ilr = -1 -!!$ ilc = -1 -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ i1 = a%ia2(ir) -!!$ i2 = a%ia2(ir+1) -!!$ nc = i2-i1 -!!$ ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ end do -!!$ -!!$ case default -!!$ info = -3 -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Duplicate handling: ',dupl -!!$ end select -!!$ end if -!!$ -!!$ end subroutine s_csr_srch_upd -!!$ -!!$ subroutine s_coo_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_realloc_mod -!!$ use psb_string_mod -!!$ use psb_serial_mod -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(inout) :: a -!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl -!!$ integer, intent(in) :: ia(:),ja(:) -!!$ integer, intent(inout) :: nza -!!$ real(psb_spk_), intent(in) :: val(:) -!!$ integer, intent(out) :: info -!!$ integer, intent(in), optional :: ng,gtl(:) -!!$ integer :: i,ir,ic, ilr, ilc, ip, & -!!$ & i1,i2,nc,nnz,dupl -!!$ integer :: debug_level, debug_unit -!!$ character(len=20) :: name='s_coo_srch_upd' -!!$ -!!$ info = 0 -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ dupl = psb_sp_getifld(psb_dupl_,a,info) -!!$ -!!$ if (psb_sp_getifld(psb_srtd_,a,info) /= psb_isrtdcoo_) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ -!!$ ilr = -1 -!!$ ilc = -1 -!!$ nnz = psb_sp_getifld(psb_nnz_,a,info) -!!$ -!!$ -!!$ if (present(gtl)) then -!!$ if (.not.present(ng)) then -!!$ info = -1 -!!$ return -!!$ endif -!!$ -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ ! Overwrite. -!!$ ! Cannot test for error, should have been caught earlier. -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ ic = gtl(ic) -!!$ if (ir /= ilr) then -!!$ i1 = psb_ibsrch(ir,nnz,a%ia1) -!!$ i2 = i1 -!!$ do -!!$ if (i2+1 > nnz) exit -!!$ if (a%ia1(i2+1) /= a%ia1(i2)) exit -!!$ i2 = i2 + 1 -!!$ end do -!!$ do -!!$ if (i1-1 < 1) exit -!!$ if (a%ia1(i1-1) /= a%ia1(i1)) exit -!!$ i1 = i1 - 1 -!!$ end do -!!$ ilr = ir -!!$ else -!!$ i1 = 1 -!!$ i2 = 1 -!!$ end if -!!$ nc = i2-i1+1 -!!$ ip = psb_issrch(ic,nc,a%ia2(i1:i2)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ endif -!!$ end if -!!$ end do -!!$ case(psb_dupl_add_) -!!$ ! Add -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ ic = gtl(ic) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ -!!$ if (ir /= ilr) then -!!$ i1 = psb_ibsrch(ir,nnz,a%ia1) -!!$ i2 = i1 -!!$ do -!!$ if (i2+1 > nnz) exit -!!$ if (a%ia1(i2+1) /= a%ia1(i2)) exit -!!$ i2 = i2 + 1 -!!$ end do -!!$ do -!!$ if (i1-1 < 1) exit -!!$ if (a%ia1(i1-1) /= a%ia1(i1)) exit -!!$ i1 = i1 - 1 -!!$ end do -!!$ ilr = ir -!!$ else -!!$ i1 = 1 -!!$ i2 = 1 -!!$ end if -!!$ nc = i2-i1+1 -!!$ ip = psb_issrch(ic,nc,a%ia2(i1:i2)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case default -!!$ info = -3 -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Duplicate handling: ',dupl -!!$ end select -!!$ -!!$ else -!!$ -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ ! Overwrite. -!!$ ! Cannot test for error, should have been caught earlier. -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ -!!$ if (ir /= ilr) then -!!$ i1 = psb_ibsrch(ir,nnz,a%ia1) -!!$ i2 = i1 -!!$ do -!!$ if (i2+1 > nnz) exit -!!$ if (a%ia1(i2+1) /= a%ia1(i2)) exit -!!$ i2 = i2 + 1 -!!$ end do -!!$ do -!!$ if (i1-1 < 1) exit -!!$ if (a%ia1(i1-1) /= a%ia1(i1)) exit -!!$ i1 = i1 - 1 -!!$ end do -!!$ ilr = ir -!!$ else -!!$ i1 = 1 -!!$ i2 = 1 -!!$ end if -!!$ nc = i2-i1+1 -!!$ ip = psb_issrch(ic,nc,a%ia2(i1:i2)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case(psb_dupl_add_) -!!$ ! Add -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ -!!$ if (ir /= ilr) then -!!$ i1 = psb_ibsrch(ir,nnz,a%ia1) -!!$ i2 = i1 -!!$ do -!!$ if (i2+1 > nnz) exit -!!$ if (a%ia1(i2+1) /= a%ia1(i2)) exit -!!$ i2 = i2 + 1 -!!$ end do -!!$ do -!!$ if (i1-1 < 1) exit -!!$ if (a%ia1(i1-1) /= a%ia1(i1)) exit -!!$ i1 = i1 - 1 -!!$ end do -!!$ ilr = ir -!!$ else -!!$ i1 = 1 -!!$ i2 = 1 -!!$ end if -!!$ nc = i2-i1+1 -!!$ ip = psb_issrch(ic,nc,a%ia2(i1:i2)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case default -!!$ info = -3 -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Duplicate handling: ',dupl -!!$ end select -!!$ -!!$ end if -!!$ -!!$ end subroutine s_coo_srch_upd -!!$ -!!$ subroutine s_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_realloc_mod -!!$ use psb_string_mod -!!$ use psb_serial_mod -!!$ -!!$ implicit none -!!$ -!!$ type(psb_sspmat_type), intent(inout), target :: a -!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl -!!$ integer, intent(in) :: ia(:),ja(:) -!!$ integer, intent(inout) :: nza -!!$ real(psb_spk_), intent(in) :: val(:) -!!$ integer, intent(out) :: info -!!$ integer, intent(in), optional :: ng,gtl(:) -!!$ -!!$ integer, pointer :: ia1(:), ia2(:), ia3(:),& -!!$ & ja_(:), ka_(:) -!!$ integer, allocatable :: indices(:), blks(:), rows(:) -!!$ integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr,& -!!$ & i,j,nr,dupl, ii, ir, ic -!!$ -!!$ info = 0 -!!$ dupl = psb_sp_getifld(psb_dupl_,a,info) -!!$ -!!$ png = a%ia2(1) ! points to the number of blocks -!!$ pia = a%ia2(2) ! points to the beginning of ia(3,png) -!!$ pja = a%ia2(3) ! points to the beginning of ja(:) -!!$ -!!$ ngr = a%ia2(png) ! the number of blocks -!!$ ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk -!!$ ka_ => a%ia1(:) ! the array containing the column indices -!!$ ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index -!!$ ! of each block -!!$ ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. -!!$ ! in ja to the first jad column -!!$ ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. -!!$ ! in ja to the first csr column -!!$ -!!$ -!!$ if (a%pl(1) /= 0) then -!!$ -!!$ if (present(gtl)) then -!!$ if (.not.present(ng)) then -!!$ info = -1 -!!$ return -!!$ endif -!!$ -!!$ -!!$ allocate(rows(nz),stat=info) -!!$ if (info /= 0) then -!!$ info = -4010 -!!$ return -!!$ endif -!!$ j=0 -!!$ do i=1,nz -!!$ ir = ia(i) -!!$ if ((ir >=1).and.(ir<=ng)) then -!!$ ir = gtl(ir) -!!$ j = j + 1 -!!$ rows(j) = ir -!!$ endif -!!$ enddo -!!$ call psb_msort_unique(rows(1:j),nr) -!!$ allocate(indices(nr),blks(nr),stat=info) -!!$ if (info /= 0) then -!!$ info = -4010 -!!$ return -!!$ endif -!!$ -!!$ do i=1,nr -!!$ indices(i)=a%pl(rows(i)) -!!$ j=0 -!!$ blkfnd_gtl: do -!!$ j=j+1 -!!$ if(ia1(j) == indices(i)) then -!!$ blks(i)=j -!!$ ipx = ia1(j) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j)+rb -!!$ exit blkfnd_gtl -!!$ else if(ia1(j) > indices(i)) then -!!$ blks(i)=j-1 -!!$ ipx = ia1(j-1) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j-1)+rb -!!$ exit blkfnd_gtl -!!$ end if -!!$ end do blkfnd_gtl -!!$ end do -!!$ -!!$ -!!$ ! cycle over elements -!!$ update_gtl: do ii=1,nz -!!$ ir = ia(ii) -!!$ ic = ja(ii) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ ic = gtl(ic) -!!$ i = psb_ibsrch(ir,nr,rows) -!!$ -!!$ ! find which block the row belongs to -!!$ blk = blks(i) -!!$ -!!$ ! extract first part of the row from the jad block -!!$ ipx = ia1(blk) ! the first row index of the block -!!$ k_pt= ia2(blk) ! the pointer to the beginning of a column in ja -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block -!!$ -!!$ do col = ia2(blk), ia3(blk)-1 -!!$ if (ic == ka_(ja_(col)+rb)) then -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ a%aspk(ja_(col)+rb) = val(ii) -!!$ case(psb_dupl_add_) -!!$ a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) -!!$ end select -!!$ cycle update_gtl -!!$ endif -!!$ end do -!!$ -!!$ ! extract second part of the row from the csr tail just in case -!!$ row=ia3(blk)+rb -!!$ do j=ja_(row), ja_(row+1)-1 -!!$ if (ic == ka_(j)) then -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ a%aspk(j) = val(ii) -!!$ case(psb_dupl_add_) -!!$ a%aspk(j) = a%aspk(j) + val(ii) -!!$ end select -!!$ cycle update_gtl -!!$ endif -!!$ end do -!!$ end if -!!$ end if -!!$ end do update_gtl -!!$ -!!$ else -!!$ -!!$ allocate(rows(nz),stat=info) -!!$ if (info /= 0) then -!!$ info = -4010 -!!$ return -!!$ endif -!!$ j=0 -!!$ do i=1,nz -!!$ ir = ia(i) -!!$ if ((ir >=1).and.(ir<=a%m)) then -!!$ j = j + 1 -!!$ rows(j) = ir -!!$ endif -!!$ enddo -!!$ call psb_msort_unique(rows(1:j),nr) -!!$ allocate(indices(nr),blks(nr),stat=info) -!!$ if (info /= 0) then -!!$ info = -4010 -!!$ return -!!$ endif -!!$ -!!$ do i=1,nr -!!$ indices(i)=a%pl(rows(i)) -!!$ j=0 -!!$ blkfnd: do -!!$ j=j+1 -!!$ if(ia1(j) == indices(i)) then -!!$ blks(i)=j -!!$ ipx = ia1(j) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j)+rb -!!$ exit blkfnd -!!$ else if(ia1(j) > indices(i)) then -!!$ blks(i)=j-1 -!!$ ipx = ia1(j-1) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j-1)+rb -!!$ exit blkfnd -!!$ end if -!!$ end do blkfnd -!!$ end do -!!$ -!!$ -!!$ ! cycle over elements -!!$ update: do ii=1,nz -!!$ ir = ia(ii) -!!$ ic = ja(ii) -!!$ if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then -!!$ i = psb_ibsrch(ir,nr,rows) -!!$ ! find which block the row belongs to -!!$ blk = blks(i) -!!$ -!!$ ! extract first part of the row from the jad block -!!$ ipx = ia1(blk) ! the first row index of the block -!!$ k_pt= ia2(blk) ! the pointer to the beginning of a column in ja -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block -!!$ -!!$ do col = ia2(blk), ia3(blk)-1 -!!$ if (ic == ka_(ja_(col)+rb)) then -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ a%aspk(ja_(col)+rb) = val(ii) -!!$ case(psb_dupl_add_) -!!$ a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) -!!$ end select -!!$ cycle update -!!$ endif -!!$ end do -!!$ -!!$ ! extract second part of the row from the csr tail just in case -!!$ row=ia3(blk)+rb -!!$ do j=ja_(row), ja_(row+1)-1 -!!$ if (ic == ka_(j)) then -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ a%aspk(j) = val(ii) -!!$ case(psb_dupl_add_) -!!$ a%aspk(j) = a%aspk(j) + val(ii) -!!$ end select -!!$ cycle update -!!$ endif -!!$ end do -!!$ end if -!!$ end do update -!!$ -!!$ end if -!!$ else -!!$ ! There might be some problems -!!$ info=134 -!!$ end if -!!$ -!!$ end subroutine s_jad_srch_upd -!!$ -!!$ subroutine d_csr_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_realloc_mod -!!$ use psb_string_mod -!!$ use psb_serial_mod -!!$ use psb_error_mod -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(inout) :: a -!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl -!!$ integer, intent(in) :: ia(:),ja(:) -!!$ integer, intent(inout) :: nza -!!$ real(psb_dpk_), intent(in) :: val(:) -!!$ integer, intent(out) :: info -!!$ integer, intent(in), optional :: ng,gtl(:) -!!$ -!!$ integer :: debug_level, debug_unit -!!$ character(len=20) :: name='d_csr_srch_upd' -!!$ integer :: i,ir,ic, ilr, ilc, ip, & -!!$ & i1,i2,nc,lb,ub,m,dupl -!!$ -!!$ info = 0 -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ -!!$ dupl = psb_sp_getifld(psb_dupl_,a,info) -!!$ -!!$ if (present(gtl)) then -!!$ if (.not.present(ng)) then -!!$ info = -1 -!!$ return -!!$ endif -!!$ -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ ! Overwrite. -!!$ ! Cannot test for error, should have been caught earlier. -!!$ -!!$ ilr = -1 -!!$ ilc = -1 -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ ic = gtl(ic) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ i1 = a%ia2(ir) -!!$ i2 = a%ia2(ir+1) -!!$ nc=i2-i1 -!!$ -!!$ ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = val(i) -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Was searching ',ic,' in: ',i1,i2,& -!!$ & ' : ',a%ia1(i1:i2-1) -!!$ info = i -!!$ return -!!$ end if -!!$ -!!$ else -!!$ -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case(psb_dupl_add_) -!!$ ! Add -!!$ ilr = -1 -!!$ ilc = -1 -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ ic = gtl(ic) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ i1 = a%ia2(ir) -!!$ i2 = a%ia2(ir+1) -!!$ nc = i2-i1 -!!$ ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Was searching ',ic,' in: ',i1,i2,& -!!$ & ' : ',a%ia1(i1:i2-1) -!!$ info = i -!!$ return -!!$ end if -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ -!!$ end if -!!$ end do -!!$ -!!$ case default -!!$ info = -3 -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Duplicate handling: ',dupl -!!$ end select -!!$ -!!$ else -!!$ -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ ! Overwrite. -!!$ ! Cannot test for error, should have been caught earlier. -!!$ -!!$ ilr = -1 -!!$ ilc = -1 -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ -!!$ i1 = a%ia2(ir) -!!$ i2 = a%ia2(ir+1) -!!$ nc=i2-i1 -!!$ -!!$ ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = val(i) -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Was searching ',ic,' in: ',i1,i2,& -!!$ & ' : ',a%ia1(i1:i2-1) -!!$ info = i -!!$ return -!!$ end if -!!$ -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ -!!$ end do -!!$ -!!$ case(psb_dupl_add_) -!!$ ! Add -!!$ ilr = -1 -!!$ ilc = -1 -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ i1 = a%ia2(ir) -!!$ i2 = a%ia2(ir+1) -!!$ nc = i2-i1 -!!$ ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ end do -!!$ -!!$ case default -!!$ info = -3 -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Duplicate handling: ',dupl -!!$ end select -!!$ end if -!!$ -!!$ end subroutine d_csr_srch_upd -!!$ -!!$ subroutine d_coo_srch_upd(nz,ia,ja,val,nza,a,& -!!$ & imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_realloc_mod -!!$ use psb_string_mod -!!$ use psb_serial_mod -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(inout) :: a -!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl -!!$ integer, intent(in) :: ia(:),ja(:) -!!$ integer, intent(inout) :: nza -!!$ real(psb_dpk_), intent(in) :: val(:) -!!$ integer, intent(out) :: info -!!$ integer, intent(in), optional :: ng,gtl(:) -!!$ integer :: i,ir,ic, ilr, ilc, ip, & -!!$ & i1,i2,nc,nnz,dupl -!!$ integer :: debug_level, debug_unit -!!$ character(len=20) :: name='d_coo_srch_upd' -!!$ -!!$ info = 0 -!!$ debug_unit = psb_get_debug_unit() -!!$ debug_level = psb_get_debug_level() -!!$ dupl = psb_sp_getifld(psb_dupl_,a,info) -!!$ -!!$ if (psb_sp_getifld(psb_srtd_,a,info) /= psb_isrtdcoo_) then -!!$ info = -4 -!!$ return -!!$ end if -!!$ -!!$ ilr = -1 -!!$ ilc = -1 -!!$ nnz = psb_sp_getifld(psb_nnz_,a,info) -!!$ -!!$ -!!$ if (present(gtl)) then -!!$ if (.not.present(ng)) then -!!$ info = -1 -!!$ return -!!$ endif -!!$ -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ ! Overwrite. -!!$ ! Cannot test for error, should have been caught earlier. -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ ic = gtl(ic) -!!$ if (ir /= ilr) then -!!$ i1 = psb_ibsrch(ir,nnz,a%ia1) -!!$ i2 = i1 -!!$ do -!!$ if (i2+1 > nnz) exit -!!$ if (a%ia1(i2+1) /= a%ia1(i2)) exit -!!$ i2 = i2 + 1 -!!$ end do -!!$ do -!!$ if (i1-1 < 1) exit -!!$ if (a%ia1(i1-1) /= a%ia1(i1)) exit -!!$ i1 = i1 - 1 -!!$ end do -!!$ ilr = ir -!!$ else -!!$ i1 = 1 -!!$ i2 = 1 -!!$ end if -!!$ nc = i2-i1+1 -!!$ ip = psb_issrch(ic,nc,a%ia2(i1:i2)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ endif -!!$ end if -!!$ end do -!!$ case(psb_dupl_add_) -!!$ ! Add -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ ic = gtl(ic) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ -!!$ if (ir /= ilr) then -!!$ i1 = psb_ibsrch(ir,nnz,a%ia1) -!!$ i2 = i1 -!!$ do -!!$ if (i2+1 > nnz) exit -!!$ if (a%ia1(i2+1) /= a%ia1(i2)) exit -!!$ i2 = i2 + 1 -!!$ end do -!!$ do -!!$ if (i1-1 < 1) exit -!!$ if (a%ia1(i1-1) /= a%ia1(i1)) exit -!!$ i1 = i1 - 1 -!!$ end do -!!$ ilr = ir -!!$ else -!!$ i1 = 1 -!!$ i2 = 1 -!!$ end if -!!$ nc = i2-i1+1 -!!$ ip = psb_issrch(ic,nc,a%ia2(i1:i2)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ else -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Discarding row that does not belong to us.' -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case default -!!$ info = -3 -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Duplicate handling: ',dupl -!!$ end select -!!$ -!!$ else -!!$ -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ ! Overwrite. -!!$ ! Cannot test for error, should have been caught earlier. -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ -!!$ if (ir /= ilr) then -!!$ i1 = psb_ibsrch(ir,nnz,a%ia1) -!!$ i2 = i1 -!!$ do -!!$ if (i2+1 > nnz) exit -!!$ if (a%ia1(i2+1) /= a%ia1(i2)) exit -!!$ i2 = i2 + 1 -!!$ end do -!!$ do -!!$ if (i1-1 < 1) exit -!!$ if (a%ia1(i1-1) /= a%ia1(i1)) exit -!!$ i1 = i1 - 1 -!!$ end do -!!$ ilr = ir -!!$ else -!!$ i1 = 1 -!!$ i2 = 1 -!!$ end if -!!$ nc = i2-i1+1 -!!$ ip = psb_issrch(ic,nc,a%ia2(i1:i2)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case(psb_dupl_add_) -!!$ ! Add -!!$ do i=1, nz -!!$ ir = ia(i) -!!$ ic = ja(i) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ -!!$ if (ir /= ilr) then -!!$ i1 = psb_ibsrch(ir,nnz,a%ia1) -!!$ i2 = i1 -!!$ do -!!$ if (i2+1 > nnz) exit -!!$ if (a%ia1(i2+1) /= a%ia1(i2)) exit -!!$ i2 = i2 + 1 -!!$ end do -!!$ do -!!$ if (i1-1 < 1) exit -!!$ if (a%ia1(i1-1) /= a%ia1(i1)) exit -!!$ i1 = i1 - 1 -!!$ end do -!!$ ilr = ir -!!$ else -!!$ i1 = 1 -!!$ i2 = 1 -!!$ end if -!!$ nc = i2-i1+1 -!!$ ip = psb_issrch(ic,nc,a%ia2(i1:i2)) -!!$ if (ip>0) then -!!$ a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) -!!$ else -!!$ info = i -!!$ return -!!$ end if -!!$ end if -!!$ end do -!!$ -!!$ case default -!!$ info = -3 -!!$ if (debug_level >= psb_debug_serial_) & -!!$ & write(debug_unit,*) trim(name),& -!!$ & ': Duplicate handling: ',dupl -!!$ end select -!!$ -!!$ end if -!!$ -!!$ end subroutine d_coo_srch_upd -!!$ -!!$ subroutine d_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng) -!!$ -!!$ use psb_spmat_type -!!$ use psb_const_mod -!!$ use psb_realloc_mod -!!$ use psb_string_mod -!!$ use psb_serial_mod -!!$ -!!$ implicit none -!!$ -!!$ type(psb_dspmat_type), intent(inout), target :: a -!!$ integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl -!!$ integer, intent(in) :: ia(:),ja(:) -!!$ integer, intent(inout) :: nza -!!$ real(psb_dpk_), intent(in) :: val(:) -!!$ integer, intent(out) :: info -!!$ integer, intent(in), optional :: ng,gtl(:) -!!$ -!!$ integer, pointer :: ia1(:), ia2(:), ia3(:),& -!!$ & ja_(:), ka_(:) -!!$ integer, allocatable :: indices(:), blks(:), rows(:) -!!$ integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr,& -!!$ & i,j,nr,dupl, ii, ir, ic -!!$ -!!$ info = 0 -!!$ dupl = psb_sp_getifld(psb_dupl_,a,info) -!!$ -!!$ png = a%ia2(1) ! points to the number of blocks -!!$ pia = a%ia2(2) ! points to the beginning of ia(3,png) -!!$ pja = a%ia2(3) ! points to the beginning of ja(:) -!!$ -!!$ ngr = a%ia2(png) ! the number of blocks -!!$ ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk -!!$ ka_ => a%ia1(:) ! the array containing the column indices -!!$ ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index -!!$ ! of each block -!!$ ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. -!!$ ! in ja to the first jad column -!!$ ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. -!!$ ! in ja to the first csr column -!!$ -!!$ -!!$ if (a%pl(1) /= 0) then -!!$ -!!$ if (present(gtl)) then -!!$ if (.not.present(ng)) then -!!$ info = -1 -!!$ return -!!$ endif -!!$ -!!$ -!!$ allocate(rows(nz),stat=info) -!!$ if (info /= 0) then -!!$ info = -4010 -!!$ return -!!$ endif -!!$ j=0 -!!$ do i=1,nz -!!$ ir = ia(i) -!!$ if ((ir >=1).and.(ir<=ng)) then -!!$ ir = gtl(ir) -!!$ j = j + 1 -!!$ rows(j) = ir -!!$ endif -!!$ enddo -!!$ call psb_msort_unique(rows(1:j),nr) -!!$ allocate(indices(nr),blks(nr),stat=info) -!!$ if (info /= 0) then -!!$ info = -4010 -!!$ return -!!$ endif -!!$ -!!$ do i=1,nr -!!$ indices(i)=a%pl(rows(i)) -!!$ j=0 -!!$ blkfnd_gtl: do -!!$ j=j+1 -!!$ if(ia1(j) == indices(i)) then -!!$ blks(i)=j -!!$ ipx = ia1(j) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j)+rb -!!$ exit blkfnd_gtl -!!$ else if(ia1(j) > indices(i)) then -!!$ blks(i)=j-1 -!!$ ipx = ia1(j-1) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j-1)+rb -!!$ exit blkfnd_gtl -!!$ end if -!!$ end do blkfnd_gtl -!!$ end do -!!$ -!!$ -!!$ ! cycle over elements -!!$ update_gtl: do ii=1,nz -!!$ ir = ia(ii) -!!$ ic = ja(ii) -!!$ if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then -!!$ ir = gtl(ir) -!!$ if ((ir > 0).and.(ir <= a%m)) then -!!$ ic = gtl(ic) -!!$ i = psb_ibsrch(ir,nr,rows) -!!$ -!!$ ! find which block the row belongs to -!!$ blk = blks(i) -!!$ -!!$ ! extract first part of the row from the jad block -!!$ ipx = ia1(blk) ! the first row index of the block -!!$ k_pt= ia2(blk) ! the pointer to the beginning of a column in ja -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block -!!$ -!!$ do col = ia2(blk), ia3(blk)-1 -!!$ if (ic == ka_(ja_(col)+rb)) then -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ a%aspk(ja_(col)+rb) = val(ii) -!!$ case(psb_dupl_add_) -!!$ a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) -!!$ end select -!!$ cycle update_gtl -!!$ endif -!!$ end do -!!$ -!!$ ! extract second part of the row from the csr tail just in case -!!$ row=ia3(blk)+rb -!!$ do j=ja_(row), ja_(row+1)-1 -!!$ if (ic == ka_(j)) then -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ a%aspk(j) = val(ii) -!!$ case(psb_dupl_add_) -!!$ a%aspk(j) = a%aspk(j) + val(ii) -!!$ end select -!!$ cycle update_gtl -!!$ endif -!!$ end do -!!$ end if -!!$ end if -!!$ end do update_gtl -!!$ -!!$ else -!!$ -!!$ allocate(rows(nz),stat=info) -!!$ if (info /= 0) then -!!$ info = -4010 -!!$ return -!!$ endif -!!$ j=0 -!!$ do i=1,nz -!!$ ir = ia(i) -!!$ if ((ir >=1).and.(ir<=a%m)) then -!!$ j = j + 1 -!!$ rows(j) = ir -!!$ endif -!!$ enddo -!!$ call psb_msort_unique(rows(1:j),nr) -!!$ allocate(indices(nr),blks(nr),stat=info) -!!$ if (info /= 0) then -!!$ info = -4010 -!!$ return -!!$ endif -!!$ -!!$ do i=1,nr -!!$ indices(i)=a%pl(rows(i)) -!!$ j=0 -!!$ blkfnd: do -!!$ j=j+1 -!!$ if(ia1(j) == indices(i)) then -!!$ blks(i)=j -!!$ ipx = ia1(j) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j)+rb -!!$ exit blkfnd -!!$ else if(ia1(j) > indices(i)) then -!!$ blks(i)=j-1 -!!$ ipx = ia1(j-1) ! the first row index of the block -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ row = ia3(j-1)+rb -!!$ exit blkfnd -!!$ end if -!!$ end do blkfnd -!!$ end do -!!$ -!!$ -!!$ ! cycle over elements -!!$ update: do ii=1,nz -!!$ ir = ia(ii) -!!$ ic = ja(ii) -!!$ if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then -!!$ i = psb_ibsrch(ir,nr,rows) -!!$ ! find which block the row belongs to -!!$ blk = blks(i) -!!$ -!!$ ! extract first part of the row from the jad block -!!$ ipx = ia1(blk) ! the first row index of the block -!!$ k_pt= ia2(blk) ! the pointer to the beginning of a column in ja -!!$ rb = indices(i)-ipx ! the row offset within the block -!!$ npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block -!!$ -!!$ do col = ia2(blk), ia3(blk)-1 -!!$ if (ic == ka_(ja_(col)+rb)) then -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ a%aspk(ja_(col)+rb) = val(ii) -!!$ case(psb_dupl_add_) -!!$ a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) -!!$ end select -!!$ cycle update -!!$ endif -!!$ end do -!!$ -!!$ ! extract second part of the row from the csr tail just in case -!!$ row=ia3(blk)+rb -!!$ do j=ja_(row), ja_(row+1)-1 -!!$ if (ic == ka_(j)) then -!!$ select case(dupl) -!!$ case(psb_dupl_ovwrt_,psb_dupl_err_) -!!$ a%aspk(j) = val(ii) -!!$ case(psb_dupl_add_) -!!$ a%aspk(j) = a%aspk(j) + val(ii) -!!$ end select -!!$ cycle update -!!$ endif -!!$ end do -!!$ end if -!!$ end do update -!!$ -!!$ end if -!!$ else -!!$ ! There might be some problems -!!$ info=134 -!!$ end if -!!$ -!!$ end subroutine d_jad_srch_upd -!!$ - - subroutine c_csr_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_serial_mod - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_spk_), intent(in) :: val(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - - integer :: i,ir,ic, ilr, ilc, ip, & - & i1,i2,nc,lb,ub,m,dupl - - integer :: debug_level, debug_unit - character(len=20) :: name='c_csr_srch_upd' - - info = 0 - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - dupl = psb_sp_getifld(psb_dupl_,a,info) - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - - ilr = -1 - ilc = -1 - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= a%m)) then - i1 = a%ia2(ir) - i2 = a%ia2(ir+1) - nc=i2-i1 - - ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) - if (ip>0) then - a%aspk(i1+ip-1) = val(i) - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Was searching ',ic,' in: ',i1,i2,& - & ' : ',a%ia1(i1:i2-1) - info = i - return - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - end if - end do - - case(psb_dupl_add_) - ! Add - ilr = -1 - ilc = -1 - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= a%m)) then - i1 = a%ia2(ir) - i2 = a%ia2(ir+1) - nc = i2-i1 - ip = psb_issrch(ic,nc,a%ia1(i1:i2-1)) - if (ip>0) then - a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Was searching ',ic,' in: ',i1,i2,& - & ' : ',a%ia1(i1:i2-1) - info = i - return - end if - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - else - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - - ilr = -1 - ilc = -1 - do i=1, nz - ir = ia(i) - ic = ja(i) - - if ((ir > 0).and.(ir <= a%m)) then - - i1 = a%ia2(ir) - i2 = a%ia2(ir+1) - nc=i2-i1 - - ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) - if (ip>0) then - a%aspk(i1+ip-1) = val(i) - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Was searching ',ic,' in: ',i1,i2,& - & ' : ',a%ia1(i1:i2-1) - info = i - return - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - - end do - - case(psb_dupl_add_) - ! Add - ilr = -1 - ilc = -1 - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= a%m)) then - i1 = a%ia2(ir) - i2 = a%ia2(ir+1) - nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) - if (ip>0) then - a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) - else - info = i - return - end if - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - end if - - end subroutine c_csr_srch_upd - - subroutine c_coo_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_serial_mod - implicit none - - type(psb_cspmat_type), intent(inout) :: a - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_spk_), intent(in) :: val(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic, ilr, ilc, ip, & - & i1,i2,nc,nnz,dupl - integer :: debug_level, debug_unit - character(len=20) :: name='c_coo_srch_upd' - - - info = 0 - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - dupl = psb_sp_getifld(psb_dupl_,a,info) - - if (psb_sp_getifld(psb_srtd_,a,info) /= psb_isrtdcoo_) then - info = -4 - return - end if - - ilr = -1 - ilc = -1 - nnz = psb_sp_getifld(psb_nnz_,a,info) - - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - if ((ir > 0).and.(ir <= a%m)) then - ic = gtl(ic) - if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia1) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia1(i2+1) /= a%ia1(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia1(i1-1) /= a%ia1(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ia2(i1:i2)) - if (ip>0) then - a%aspk(i1+ip-1) = val(i) - else - info = i - return - end if - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - endif - end if - end do - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= a%m)) then - - if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia1) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia1(i2+1) /= a%ia1(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia1(i1-1) /= a%ia1(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ia2(i1:i2)) - if (ip>0) then - a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) - else - info = i - return - end if - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - else - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= a%m)) then - - if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia1) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia1(i2+1) /= a%ia1(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia1(i1-1) /= a%ia1(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ia2(i1:i2)) - if (ip>0) then - a%aspk(i1+ip-1) = val(i) - else - info = i - return - end if - end if - end do - - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= a%m)) then - - if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia1) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia1(i2+1) /= a%ia1(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia1(i1-1) /= a%ia1(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ia2(i1:i2)) - if (ip>0) then - a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) - else - info = i - return - end if - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - end if - - end subroutine c_coo_srch_upd - - - - subroutine c_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_serial_mod - - implicit none - - type(psb_cspmat_type), intent(inout), target :: a - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_spk_), intent(in) :: val(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - - integer, pointer :: ia1(:), ia2(:), ia3(:),& - & ja_(:), ka_(:) - integer, allocatable :: indices(:), blks(:), rows(:) - integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr,& - & i,j,nr,dupl, ii, ir, ic - - info = 0 - dupl = psb_sp_getifld(psb_dupl_,a,info) - - png = a%ia2(1) ! points to the number of blocks - pia = a%ia2(2) ! points to the beginning of ia(3,png) - pja = a%ia2(3) ! points to the beginning of ja(:) - - ngr = a%ia2(png) ! the number of blocks - ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk - ka_ => a%ia1(:) ! the array containing the column indices - ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index - ! of each block - ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. - ! in ja to the first jad column - ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. - ! in ja to the first csr column - - - if (a%pl(1) /= 0) then - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - - - allocate(rows(nz),stat=info) - if (info /= 0) then - info = -4010 - return - endif - j=0 - do i=1,nz - ir = ia(i) - if ((ir >=1).and.(ir<=ng)) then - ir = gtl(ir) - j = j + 1 - rows(j) = ir - endif - enddo - call psb_msort_unique(rows(1:j),nr) - allocate(indices(nr),blks(nr),stat=info) - if (info /= 0) then - info = -4010 - return - endif - - do i=1,nr - indices(i)=a%pl(rows(i)) - j=0 - blkfnd_gtl: do - j=j+1 - if(ia1(j) == indices(i)) then - blks(i)=j - ipx = ia1(j) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j)+rb - exit blkfnd_gtl - else if(ia1(j) > indices(i)) then - blks(i)=j-1 - ipx = ia1(j-1) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j-1)+rb - exit blkfnd_gtl - end if - end do blkfnd_gtl - end do - - - ! cycle over elements - update_gtl: do ii=1,nz - ir = ia(ii) - ic = ja(ii) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - if ((ir > 0).and.(ir <= a%m)) then - ic = gtl(ic) - i = psb_ibsrch(ir,nr,rows) - - ! find which block the row belongs to - blk = blks(i) - - ! extract first part of the row from the jad block - ipx = ia1(blk) ! the first row index of the block - k_pt= ia2(blk) ! the pointer to the beginning of a column in ja - rb = indices(i)-ipx ! the row offset within the block - npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block - - do col = ia2(blk), ia3(blk)-1 - if (ic == ka_(ja_(col)+rb)) then - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - a%aspk(ja_(col)+rb) = val(ii) - case(psb_dupl_add_) - a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) - end select - cycle update_gtl - endif - end do - - ! extract second part of the row from the csr tail just in case - row=ia3(blk)+rb - do j=ja_(row), ja_(row+1)-1 - if (ic == ka_(j)) then - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - a%aspk(j) = val(ii) - case(psb_dupl_add_) - a%aspk(j) = a%aspk(j) + val(ii) - end select - cycle update_gtl - endif - end do - end if - end if - end do update_gtl - - else - - allocate(rows(nz),stat=info) - if (info /= 0) then - info = -4010 - return - endif - j=0 - do i=1,nz - ir = ia(i) - if ((ir >=1).and.(ir<=a%m)) then - j = j + 1 - rows(j) = ir - endif - enddo - call psb_msort_unique(rows(1:j),nr) - allocate(indices(nr),blks(nr),stat=info) - if (info /= 0) then - info = -4010 - return - endif - - do i=1,nr - indices(i)=a%pl(rows(i)) - j=0 - blkfnd: do - j=j+1 - if(ia1(j) == indices(i)) then - blks(i)=j - ipx = ia1(j) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j)+rb - exit blkfnd - else if(ia1(j) > indices(i)) then - blks(i)=j-1 - ipx = ia1(j-1) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j-1)+rb - exit blkfnd - end if - end do blkfnd - end do - - - ! cycle over elements - update: do ii=1,nz - ir = ia(ii) - ic = ja(ii) - if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then - i = psb_ibsrch(ir,nr,rows) - ! find which block the row belongs to - blk = blks(i) - - ! extract first part of the row from the jad block - ipx = ia1(blk) ! the first row index of the block - k_pt= ia2(blk) ! the pointer to the beginning of a column in ja - rb = indices(i)-ipx ! the row offset within the block - npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block - - do col = ia2(blk), ia3(blk)-1 - if (ic == ka_(ja_(col)+rb)) then - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - a%aspk(ja_(col)+rb) = val(ii) - case(psb_dupl_add_) - a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) - end select - cycle update - endif - end do - - ! extract second part of the row from the csr tail just in case - row=ia3(blk)+rb - do j=ja_(row), ja_(row+1)-1 - if (ic == ka_(j)) then - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - a%aspk(j) = val(ii) - case(psb_dupl_add_) - a%aspk(j) = a%aspk(j) + val(ii) - end select - cycle update - endif - end do - end if - end do update - - end if - else - ! There might be some problems - info=134 - end if - - end subroutine c_jad_srch_upd - - subroutine z_csr_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_serial_mod - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - - integer :: i,ir,ic, ilr, ilc, ip, & - & i1,i2,nc,lb,ub,m,dupl - - integer :: debug_level, debug_unit - character(len=20) :: name='z_csr_srch_upd' - - info = 0 - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - dupl = psb_sp_getifld(psb_dupl_,a,info) - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - - ilr = -1 - ilc = -1 - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= a%m)) then - i1 = a%ia2(ir) - i2 = a%ia2(ir+1) - nc=i2-i1 - - ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) - if (ip>0) then - a%aspk(i1+ip-1) = val(i) - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Was searching ',ic,' in: ',i1,i2,& - & ' : ',a%ia1(i1:i2-1) - info = i - return - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - end if - end do - - case(psb_dupl_add_) - ! Add - ilr = -1 - ilc = -1 - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= a%m)) then - i1 = a%ia2(ir) - i2 = a%ia2(ir+1) - nc = i2-i1 - ip = psb_issrch(ic,nc,a%ia1(i1:i2-1)) - if (ip>0) then - a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Was searching ',ic,' in: ',i1,i2,& - & ' : ',a%ia1(i1:i2-1) - info = i - return - end if - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - else - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - - ilr = -1 - ilc = -1 - do i=1, nz - ir = ia(i) - ic = ja(i) - - if ((ir > 0).and.(ir <= a%m)) then - - i1 = a%ia2(ir) - i2 = a%ia2(ir+1) - nc=i2-i1 - - ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) - if (ip>0) then - a%aspk(i1+ip-1) = val(i) - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Was searching ',ic,' in: ',i1,i2,& - & ' : ',a%ia1(i1:i2-1) - info = i - return - end if - - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - - end do - - case(psb_dupl_add_) - ! Add - ilr = -1 - ilc = -1 - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= a%m)) then - i1 = a%ia2(ir) - i2 = a%ia2(ir+1) - nc = i2-i1 - ip = psb_ibsrch(ic,nc,a%ia1(i1:i2-1)) - if (ip>0) then - a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) - else - info = i - return - end if - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - end if - - end subroutine z_csr_srch_upd - - subroutine z_coo_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_serial_mod - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic, ilr, ilc, ip, & - & i1,i2,nc,nnz,dupl - integer :: debug_level, debug_unit - character(len=20) :: name='z_coo_srch_upd' - - - info = 0 - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - dupl = psb_sp_getifld(psb_dupl_,a,info) - - if (psb_sp_getifld(psb_srtd_,a,info) /= psb_isrtdcoo_) then - info = -4 - return - end if - - ilr = -1 - ilc = -1 - nnz = psb_sp_getifld(psb_nnz_,a,info) - - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - if ((ir > 0).and.(ir <= a%m)) then - ic = gtl(ic) - if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia1) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia1(i2+1) /= a%ia1(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia1(i1-1) /= a%ia1(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ia2(i1:i2)) - if (ip>0) then - a%aspk(i1+ip-1) = val(i) - else - info = i - return - end if - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - endif - end if - end do - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir > 0).and.(ir <= a%m)) then - - if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia1) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia1(i2+1) /= a%ia1(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia1(i1-1) /= a%ia1(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ia2(i1:i2)) - if (ip>0) then - a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) - else - info = i - return - end if - else - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Discarding row that does not belong to us.' - end if - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - else - - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - ! Overwrite. - ! Cannot test for error, should have been caught earlier. - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= a%m)) then - - if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia1) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia1(i2+1) /= a%ia1(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia1(i1-1) /= a%ia1(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ia2(i1:i2)) - if (ip>0) then - a%aspk(i1+ip-1) = val(i) - else - info = i - return - end if - end if - end do - - case(psb_dupl_add_) - ! Add - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir > 0).and.(ir <= a%m)) then - - if (ir /= ilr) then - i1 = psb_ibsrch(ir,nnz,a%ia1) - i2 = i1 - do - if (i2+1 > nnz) exit - if (a%ia1(i2+1) /= a%ia1(i2)) exit - i2 = i2 + 1 - end do - do - if (i1-1 < 1) exit - if (a%ia1(i1-1) /= a%ia1(i1)) exit - i1 = i1 - 1 - end do - ilr = ir - else - i1 = 1 - i2 = 1 - end if - nc = i2-i1+1 - ip = psb_issrch(ic,nc,a%ia2(i1:i2)) - if (ip>0) then - a%aspk(i1+ip-1) = a%aspk(i1+ip-1) + val(i) - else - info = i - return - end if - end if - end do - - case default - info = -3 - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Duplicate handling: ',dupl - end select - - end if - - end subroutine z_coo_srch_upd - - - - subroutine z_jad_srch_upd(nz,ia,ja,val,nza,a,imin,imax,jmin,jmax,nzl,info,gtl,ng) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_serial_mod - - implicit none - - type(psb_zspmat_type), intent(inout), target :: a - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_dpk_), intent(in) :: val(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - - integer, pointer :: ia1(:), ia2(:), ia3(:),& - & ja_(:), ka_(:) - integer, allocatable :: indices(:), blks(:), rows(:) - integer :: png, pia, pja, ipx, blk, rb, row, k_pt, npg, col, ngr,& - & i,j,nr,dupl, ii, ir, ic - - info = 0 - dupl = psb_sp_getifld(psb_dupl_,a,info) - - png = a%ia2(1) ! points to the number of blocks - pia = a%ia2(2) ! points to the beginning of ia(3,png) - pja = a%ia2(3) ! points to the beginning of ja(:) - - ngr = a%ia2(png) ! the number of blocks - ja_ => a%ia2(pja:) ! the array containing the pointers to ka and aspk - ka_ => a%ia1(:) ! the array containing the column indices - ia1 => a%ia2(pia:pja-1:3) ! the array containing the first row index - ! of each block - ia2 => a%ia2(pia+1:pja-1:3) ! the array containing a pointer to the pos. - ! in ja to the first jad column - ia3 => a%ia2(pia+2:pja-1:3) ! the array containing a pointer to the pos. - ! in ja to the first csr column - - - if (a%pl(1) /= 0) then - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - - - allocate(rows(nz),stat=info) - if (info /= 0) then - info = -4010 - return - endif - j=0 - do i=1,nz - ir = ia(i) - if ((ir >=1).and.(ir<=ng)) then - ir = gtl(ir) - j = j + 1 - rows(j) = ir - endif - enddo - call psb_msort_unique(rows(1:j),nr) - allocate(indices(nr),blks(nr),stat=info) - if (info /= 0) then - info = -4010 - return - endif - - do i=1,nr - indices(i)=a%pl(rows(i)) - j=0 - blkfnd_gtl: do - j=j+1 - if(ia1(j) == indices(i)) then - blks(i)=j - ipx = ia1(j) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j)+rb - exit blkfnd_gtl - else if(ia1(j) > indices(i)) then - blks(i)=j-1 - ipx = ia1(j-1) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j-1)+rb - exit blkfnd_gtl - end if - end do blkfnd_gtl - end do - - - ! cycle over elements - update_gtl: do ii=1,nz - ir = ia(ii) - ic = ja(ii) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - if ((ir > 0).and.(ir <= a%m)) then - ic = gtl(ic) - i = psb_ibsrch(ir,nr,rows) - - ! find which block the row belongs to - blk = blks(i) - - ! extract first part of the row from the jad block - ipx = ia1(blk) ! the first row index of the block - k_pt= ia2(blk) ! the pointer to the beginning of a column in ja - rb = indices(i)-ipx ! the row offset within the block - npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block - - do col = ia2(blk), ia3(blk)-1 - if (ic == ka_(ja_(col)+rb)) then - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - a%aspk(ja_(col)+rb) = val(ii) - case(psb_dupl_add_) - a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) - end select - cycle update_gtl - endif - end do - - ! extract second part of the row from the csr tail just in case - row=ia3(blk)+rb - do j=ja_(row), ja_(row+1)-1 - if (ic == ka_(j)) then - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - a%aspk(j) = val(ii) - case(psb_dupl_add_) - a%aspk(j) = a%aspk(j) + val(ii) - end select - cycle update_gtl - endif - end do - end if - end if - end do update_gtl - - else - - allocate(rows(nz),stat=info) - if (info /= 0) then - info = -4010 - return - endif - j=0 - do i=1,nz - ir = ia(i) - if ((ir >=1).and.(ir<=a%m)) then - j = j + 1 - rows(j) = ir - endif - enddo - call psb_msort_unique(rows(1:j),nr) - allocate(indices(nr),blks(nr),stat=info) - if (info /= 0) then - info = -4010 - return - endif - - do i=1,nr - indices(i)=a%pl(rows(i)) - j=0 - blkfnd: do - j=j+1 - if(ia1(j) == indices(i)) then - blks(i)=j - ipx = ia1(j) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j)+rb - exit blkfnd - else if(ia1(j) > indices(i)) then - blks(i)=j-1 - ipx = ia1(j-1) ! the first row index of the block - rb = indices(i)-ipx ! the row offset within the block - row = ia3(j-1)+rb - exit blkfnd - end if - end do blkfnd - end do - - - ! cycle over elements - update: do ii=1,nz - ir = ia(ii) - ic = ja(ii) - if ((ir >=1).and.(ir<=a%m).and.(ic>=1).and.(ic<=a%k)) then - i = psb_ibsrch(ir,nr,rows) - ! find which block the row belongs to - blk = blks(i) - - ! extract first part of the row from the jad block - ipx = ia1(blk) ! the first row index of the block - k_pt= ia2(blk) ! the pointer to the beginning of a column in ja - rb = indices(i)-ipx ! the row offset within the block - npg = ja_(k_pt+1)-ja_(k_pt) ! the number of rows in the block - - do col = ia2(blk), ia3(blk)-1 - if (ic == ka_(ja_(col)+rb)) then - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - a%aspk(ja_(col)+rb) = val(ii) - case(psb_dupl_add_) - a%aspk(ja_(col)+rb) = a%aspk(ja_(col)+rb) + val(ii) - end select - cycle update - endif - end do - - ! extract second part of the row from the csr tail just in case - row=ia3(blk)+rb - do j=ja_(row), ja_(row+1)-1 - if (ic == ka_(j)) then - select case(dupl) - case(psb_dupl_ovwrt_,psb_dupl_err_) - a%aspk(j) = val(ii) - case(psb_dupl_add_) - a%aspk(j) = a%aspk(j) + val(ii) - end select - cycle update - endif - end do - end if - end do update - - end if - else - ! There might be some problems - info=134 - end if - - end subroutine z_jad_srch_upd - - -end module psb_update_mod - diff --git a/base/serial/psb_zcoins.f90 b/base/serial/psb_zcoins.f90 deleted file mode 100644 index 4cfa6d911..000000000 --- a/base/serial/psb_zcoins.f90 +++ /dev/null @@ -1,620 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcoins.f90 -! Subroutine: psb_zcoins -! Takes a cloud of coefficients and inserts them into a sparse matrix. -! This subroutine is the serial, inner counterpart to the outer, user-level -! psb_spins. -! -! Arguments: -! -! nz - integer, input The number of points to insert. -! ia(:) - integer, input The row indices of the coefficients. -! ja(:) - integer, input The column indices of the coefficients. -! val(:) - complex, input The values of the coefficients to be inserted. -! a - type(psb_zspmat_type), inout The sparse destination matrix. -! imin - integer, input The minimum valid row index -! imax - integer, input The maximum valid row index -! jmin - integer, input The minimum valid col index -! jmax - integer, input The maximum valid col index -! info - integer, output Return code. -! gtl(:) - integer, input,optional An index mapping to be applied -! default: identity -! rebuild - logical, input, optional Rebuild in case of update -! finding a new index. Default: false. -! Not fully tested. -! -subroutine psb_zcoins(nz,ia,ja,val,a,imin,imax,jmin,jmax,info,gtl,rebuild) - - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_string_mod - use psb_error_mod - use psb_serial_mod, psb_protect_name => psb_zcoins - use psb_update_mod - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax - integer, intent(in) :: ia(:),ja(:) - complex(psb_dpk_), intent(in) :: val(:) - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - integer, intent(in), optional :: gtl(:) - logical, intent(in), optional :: rebuild - - character(len=5) :: ufida - integer :: ng, nza, isza,spstate, & - & ip1, nzl, err_act, int_err(5), iupd, irst - integer :: debug_level, debug_unit - logical :: rebuild_ - character(len=20) :: name, ch_err - type(psb_zspmat_type) :: tmp - - name='psb_zcoins' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - info = 0 - if (nz <= 0) then - info = 10 - int_err(1)=1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(ia) < nz) then - info = 35 - int_err(1)=2 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (size(ja) < nz) then - info = 35 - int_err(1)=3 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - if (size(val) < nz) then - info = 35 - int_err(1)=4 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - end if - - if (present(rebuild)) then - rebuild_ = rebuild - else - rebuild_ = .false. - end if - - ufida = psb_toupper(a%fida) - spstate = psb_sp_getifld(psb_state_,a,info) - - - if (present(gtl)) then - - ng = size(gtl) - select case(spstate) - case(psb_spmat_bld_) - if ((ufida /= 'COO').and.(ufida/='COI')) then - info = 134 - ch_err(1:3)=ufida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info,gtl,ng) - - if(info /= izero) then - - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%infoa(psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': insert discarded items ' - end if - end if - if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - endif - call psb_sp_setifld(nza,psb_nnz_,a,info) - - case(psb_spmat_upd_) - - iupd = psb_sp_getifld(psb_upd_,a,info) - select case (iupd) - case (psb_upd_perm_) - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - nzl = psb_sp_getifld(psb_del_bnd_,a,info) - select case(ufida) - case ('JAD') - nza = a%ia1(ip1+psb_nnz_) - case default - nza = a%ia2(ip1+psb_nnz_) - end select - - call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - if (info /= izero) then - ch_err='psb_inner_upd' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': update discarded items ' - end if - end if - - select case(ufida) - case ('JAD') - a%ia1(ip1+psb_nnz_) = nza - case default - a%ia2(ip1+psb_nnz_) = nza - end select - - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': (UPD) : NZA:',nza - - case (psb_upd_srch_) - - call psb_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - - if (info > 0) then - if (rebuild_) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*)& - & trim(name),& - & ': Going through rebuild_ fingers crossed!' - irst = info - call psb_nullify_sp(tmp) - call psb_spcnv(a,tmp,info,afmt='coo') - if(info /= izero) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst - call psb_move_alloc(tmp,a,info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_transfer' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) write(debug_unit,*)& - & trim(name),': Reinserting',a%fida,nza,isza,irst,nz - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - if (irst <= nz) then - call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& - & nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - &imin,imax,jmin,jmax,info,gtl,ng) - if (info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - endif - - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - call psb_sp_setifld(nza,psb_nnz_,a,info) - end if - - else - info = 2231 - call psb_errpush(info,name) - goto 9999 - end if - else if (info < 0) then - info = 2230 - call psb_errpush(info,name) - goto 9999 - - end if - - case default - - info = 2231 - call psb_errpush(info,name) - goto 9999 - end select - - - case default - info = 2232 - call psb_errpush(info,name) - goto 9999 - end select - - - - - - else - - ng = -1 - - select case(spstate) - case(psb_spmat_bld_) - if ((ufida /= 'COO').and.(ufida/='COI')) then - info = 134 - ch_err(1:3)=ufida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - - call psb_inner_ins(nz,ia,ja,val,nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info) - - if(info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - - goto 9999 - endif - if (debug_level >= psb_debug_serial_) then - if ((nza - a%infoa(psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': insert discarded items ' - end if - end if - if ((nza - psb_sp_getifld(psb_nnz_,a,info)) /= nz) then - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - endif - call psb_sp_setifld(nza,psb_nnz_,a,info) - - case(psb_spmat_upd_) - - iupd = psb_sp_getifld(psb_upd_,a,info) - select case (iupd) - case (psb_upd_perm_) - ip1 = psb_sp_getifld(psb_upd_pnt_,a,info) - nzl = psb_sp_getifld(psb_del_bnd_,a,info) - nza = a%ia2(ip1+psb_nnz_) - - - call psb_inner_upd(nz,ia,ja,val,nza,a%aspk,size(a%aspk),& - & imin,imax,jmin,jmax,nzl,info) - if (info /= izero) then - ch_err='psb_inner_upd' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) then - if ((nza - a%ia2(ip1+psb_nnz_)) /= nz) then - write(debug_unit,*) trim(name),': update discarded items ' - end if - end if - a%ia2(ip1+psb_nnz_) = nza - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),':(UPD) : NZA:',nza - - case (psb_upd_srch_) - - call psb_srch_upd(nz,ia,ja,val,nza,a,& - & imin,imax,jmin,jmax,nzl,info) - - if (info > 0) then - if (rebuild_) then - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*)& - & trim(name),& - & ': Going through rebuild_ fingers crossed!' - irst = info - call psb_nullify_sp(tmp) - call psb_spcnv(a,tmp,info,afmt='coo') - call psb_sp_setifld(psb_spmat_bld_,psb_state_,tmp,info) - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Rebuild size',tmp%infoa(psb_nnz_) ,irst - call psb_move_alloc(tmp,a,info) - call psb_sp_info(psb_nztotreq_,a,nza,info) - call psb_sp_info(psb_nzsizereq_,a,isza,info) - if(info /= izero) then - info=4010 - ch_err='psb_spinfo' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - if (debug_level >= psb_debug_serial_) write(debug_unit,*)& - & trim(name),': Reinserting',a%fida,nza,isza - - if ((nza+nz)>isza) then - call psb_sp_reall(a,max(nza+nz,int(1.5*isza)),info) - if(info /= izero) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - endif - if (irst <= nz) then - call psb_inner_ins((nz-irst+1),ia(irst:nz),ja(irst:nz),val(irst:nz),& - & nza,a%ia1,a%ia2,a%aspk,& - & min(size(a%ia1),size(a%ia2),size(a%aspk)),& - & imin,imax,jmin,jmax,info) - if (info /= izero) then - ch_err='psb_inner_ins' - call psb_errpush(4013,name,a_err=ch_err,i_err=(/info,0,0,0,0/)) - endif - - call psb_sp_setifld(nza,psb_del_bnd_,a,info) - call psb_sp_setifld(nza,psb_nnz_,a,info) - end if - - else - info = 2231 - call psb_errpush(info,name) - goto 9999 - end if - else if (info < 0) then - info = 2230 - call psb_errpush(info,name) - goto 9999 - - end if - - case default - - info = 2233 - call psb_errpush(info,name) - goto 9999 - end select - - - case default - info = 2232 - call psb_errpush(info,name) - goto 9999 - end select - endif - - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -contains - - subroutine psb_inner_upd(nz,ia,ja,val,nza,aspk,maxsz,& - & imin,imax,jmin,jmax,nzl,info,gtl,ng) - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax,nzl,maxsz - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza - complex(psb_dpk_), intent(in) :: val(:) - complex(psb_dpk_), intent(inout) :: aspk(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic - character(len=20) :: name, ch_err - - - name='psb_inner_upd' - - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - if ((nza > nzl)) then - do i=1, nz - nza = nza + 1 - if (nza>maxsz) then - call psb_errpush(50,name,i_err=(/7,maxsz,5,0,nza /)) - info = -71 - return - endif - aspk(nza) = val(i) - end do - else - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza>maxsz) then - info = -72 - return - endif - aspk(nza) = val(i) - end if - end if - end do - end if - else - if ((nza >= nzl)) then - do i=1, nz - nza = nza + 1 - if (nza>maxsz) then - info = -73 - return - endif - aspk(nza) = val(i) - end do - else - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza>maxsz) then - info = -74 - return - endif - aspk(nza) = val(i) - end if - end do - end if - end if - end subroutine psb_inner_upd - - subroutine psb_inner_ins(nz,ia,ja,val,nza,ia1,ia2,aspk,maxsz,& - & imin,imax,jmin,jmax,info,gtl,ng) - implicit none - - integer, intent(in) :: nz, imin,imax,jmin,jmax,maxsz - integer, intent(in) :: ia(:),ja(:) - integer, intent(inout) :: nza,ia1(:),ia2(:) - complex(psb_dpk_), intent(in) :: val(:) - complex(psb_dpk_), intent(inout) :: aspk(:) - integer, intent(out) :: info - integer, intent(in), optional :: ng,gtl(:) - integer :: i,ir,ic - - info = 0 - if (present(gtl)) then - if (.not.present(ng)) then - info = -1 - return - endif - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=1).and.(ir<=ng).and.(ic>=1).and.(ic<=ng)) then - ir = gtl(ir) - ic = gtl(ic) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza > maxsz) then - info = -91 - return - endif - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end if - end do - else - - do i=1, nz - ir = ia(i) - ic = ja(i) - if ((ir >=imin).and.(ir<=imax).and.(ic>=jmin).and.(ic<=jmax)) then - nza = nza + 1 - if (nza > maxsz) then - info = -92 - return - endif - ia1(nza) = ir - ia2(nza) = ic - aspk(nza) = val(i) - end if - end do - end if - - end subroutine psb_inner_ins - -end subroutine psb_zcoins - diff --git a/base/serial/psb_zcsmm.f90 b/base/serial/psb_zcsmm.f90 deleted file mode 100644 index 4357a619b..000000000 --- a/base/serial/psb_zcsmm.f90 +++ /dev/null @@ -1,89 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcsmm.f90 -! Subroutine: -! Arguments: -subroutine psb_zcsmm(alpha,a,b,beta,c,info,trans) - use psb_spmat_type, psb_protect_name => psb_zcsmm - use psb_error_mod - implicit none - - class(psb_zspmat_type) :: a - complex(psb_dpk_) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans - - complex(psb_dpk_), allocatable :: work(:) - character :: trans_ - integer :: iwsz,m,n,k,lb,lc,err_act - character(len=20) :: name - - name='psb_zcsmm' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if ((trans_=='N').or.(trans_=='n')) then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - n = min(size(b,2),size(c,2)) - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call zcsmm(trans_,m,n,k,alpha,& - & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_zcsmm diff --git a/base/serial/psb_zcsmv.f90 b/base/serial/psb_zcsmv.f90 deleted file mode 100644 index a6fa6761f..000000000 --- a/base/serial/psb_zcsmv.f90 +++ /dev/null @@ -1,90 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcsmv.f90 -! Subroutine: -! Arguments: - -subroutine psb_zcsmv(alpha,a,b,beta,c,info,trans) - use psb_spmat_type, psb_protect_name => psb_zcsmv - use psb_error_mod - implicit none - - class(psb_zspmat_type) :: a - complex(psb_dpk_) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans - - complex(psb_dpk_), allocatable :: work(:) - character :: trans_ - integer :: iwsz,m,n,k,lb,lc, err_act - character(len=20) :: name - - name='psb_zcsmv' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if ((trans_=='N').or.(trans_=='n')) then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - n = 1 - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call zcsmm(trans_,m,n,k,alpha,& - & a%pl,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,a%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_zcsmv diff --git a/base/serial/psb_zcsnmi.f90 b/base/serial/psb_zcsnmi.f90 deleted file mode 100644 index 51ef37bbc..000000000 --- a/base/serial/psb_zcsnmi.f90 +++ /dev/null @@ -1,93 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcsnmi.f90 -! Subroutine: -! Arguments: - -function psb_zcsnmi(a,info,trans) - - use psb_spmat_type - use psb_error_mod - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer, intent(out) :: info - character, optional :: trans - real(psb_dpk_) :: psb_zcsnmi - interface - function zcsnmi(trans,m,n,fida,descra,a,ia1,ia2,& - & infoa,ierror) - use psb_const_mod - real(psb_dpk_) :: zcsnmi - integer :: m,n, ierror - character :: trans - integer :: ia1(*),ia2(*),infoa(*) - character :: descra*11, fida*5 - complex(psb_dpk_) :: a(*) - end function zcsnmi - end interface - - integer :: err_act - character :: itrans - character(len=20) :: name, ch_err - - name='psb_zcsnmi' - call psb_erractionsave(err_act) - - if(present(trans)) then - itrans=trans - else - itrans='N' - end if - - psb_zcsnmi = zcsnmi(itrans,a%m,a%k,a%fida,a%descra,a%aspk,a%ia1,a%ia2,a%infoa,info) - if(info/=0) then - psb_zcsnmi = -1 - info=4010 - ch_err='psb_zcsnmi' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end function psb_zcsnmi diff --git a/base/serial/psb_zcsprt.f90 b/base/serial/psb_zcsprt.f90 deleted file mode 100644 index 2e70f87e5..000000000 --- a/base/serial/psb_zcsprt.f90 +++ /dev/null @@ -1,199 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcsprt.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* Print out a matrix. * -!* Should really align with the F77 version under the SERIAL dir, which * -!* does a nice printout in MatrixMarket format; this would be a quick job. * -!* * -!* Handles both a shift in the row/col indices and a fuctional transform * -!* on the indices. * -!* * -!* * -!* * -!* * -!***************************************************************************** -subroutine psb_zcsprt(iout,a,iv,eirs,eics,head,ivr,ivc) - use psb_spmat_type - use psb_string_mod - implicit none - - integer, intent(in) :: iout - type(psb_zspmat_type), intent(in) :: a - integer, intent(in), optional :: iv(:) - integer, intent(in), optional :: eirs,eics - character(len=*), optional :: head - integer, intent(in), optional :: ivr(:), ivc(:) - - character(len=80) :: frmtv - integer :: irs,ics,i,j, nmx, ni - - if (present(eirs)) then - irs = eirs - else - irs = 0 - endif - if (present(eics)) then - ics = eics - else - ics = 0 - endif - - if (present(head)) then - write(iout,'(a)') '%%MatrixMarket matrix coordinate complex general' - write(iout,'(a,a)') '% ',head - write(iout,'(a)') '%' - write(iout,'(a,a)') '% ',psb_toupper(a%fida) - endif - - nmx = max(a%m,a%k,1) - ni = floor(log10(1.0*nmx)) + 1 - - write(frmtv,'(a,i3.3,a,i3.3,a)') '(2(i',ni,',1x),2(es26.18,1x),2(i',ni,',1x))' - - - select case(psb_toupper(a%fida)) - - case ('CSR') - - write(iout,*) a%m,a%k,a%ia2(a%m+1)-1 - - if (present(iv)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) iv(irs+i),iv(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+i),(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+i),ivc(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+i),ivc(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+i),(ics+a%ia1(j)),a%aspk(j) - enddo - enddo - endif - endif - - case ('CSC') - - write(iout,*) a%m,a%k,a%ia2(a%k+1)-1 - - if (present(iv)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) iv(irs+a%ia1(j)),iv(ics+i),a%aspk(j) - enddo - enddo - else - if (present(ivr).and..not.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+a%ia1(j)),(ics+i),a%aspk(j) - enddo - enddo - else if (present(ivr).and.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) ivr(irs+a%ia1(j)),ivc(ics+i),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and.present(ivc)) then - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+a%ia1(j)),ivc(ics+i),a%aspk(j) - enddo - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - do i=1, a%k - do j=a%ia2(i),a%ia2(i+1)-1 - write(iout,frmtv) (irs+a%ia1(j)),(ics+i),a%aspk(j) - enddo - enddo - endif - endif - - case ('COO') - if(present(iv)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) iv(a%ia1(j)),iv(a%ia2(j)),a%aspk(j) - enddo - else - if (present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) ivr(a%ia1(j)),a%ia2(j),a%aspk(j) - enddo - else if (present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) ivr(a%ia1(j)),ivc(a%ia2(j)),a%aspk(j) - enddo - else if (.not.present(ivr).and.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) a%ia1(j),ivc(a%ia2(j)),a%aspk(j) - enddo - else if (.not.present(ivr).and..not.present(ivc)) then - write(iout,*) a%m,a%k,a%infoa(psb_nnz_) - do j=1,a%infoa(psb_nnz_) - write(iout,frmtv) a%ia1(j),a%ia2(j),a%aspk(j) - enddo - endif - endif - case default - write(0,*) 'Feeling lazy today, format not implemented: "',a%fida,'"' - end select - -end subroutine psb_zcsprt diff --git a/base/serial/psb_zcsrp.f90 b/base/serial/psb_zcsrp.f90 deleted file mode 100644 index 5caba017e..000000000 --- a/base/serial/psb_zcsrp.f90 +++ /dev/null @@ -1,157 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcsrp.f90 -! -! -! Subroutine: psb_zcsrp -! Apply a right permutation to a sparse matrix, i.e. permute the column -! indices. -! -! Arguments: -! trans - character. Whether iperm or its transpose -! should be applied -! iperm - integer, dimension(:) A permutation vector; its size -! must be either N_ROW or N_COL -! a - type(psb_zspmat_type). The matrix to be permuted -! info - integer. Eventually returns an error code -subroutine psb_zcsrp(trans,iperm,a, info) - use psb_serial_mod, psb_protect_name => psb_zcsrp - use psb_const_mod - ! implicit none - - interface - subroutine zcsrp(trans,m,n,fida,descra,ia1,ia2,& - & infoa,p,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(psb_dpk_), intent(inout) :: work(*) - integer, intent(in) :: p(*) - integer, intent(inout) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: fida*5, descra*11 - end subroutine zcsrp - end interface - - !...parameters.... - type(psb_zspmat_type), intent(inout) :: a - integer, intent(inout) :: iperm(:), info - character, intent(in) :: trans - !....locals.... - integer, allocatable :: ipt(:) - integer :: i, n_col,l_dcsdp, ipsize - complex(psb_dpk_), allocatable :: work_dcsdp(:) - integer :: n_row,err_act, int_err(5) - character(len=20) :: name, char_err - - - - n_row = psb_sp_get_nrows(a) - n_col = psb_sp_get_ncols(a) - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - name = 'psd_csrp' - - ipsize = size(iperm) - if (.not.((ipsize == n_col).or.(ipsize == n_row) )) then - info = 35 - int_err(1) = 1 - int_err(2) = ipsize - call psb_errpush(info,name,int_err) - goto 9999 - else - if (.not.psb_isaperm(ipsize,iperm)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,int_err) - goto 9999 - endif - endif - - l_dcsdp = (n_col) - - call psb_realloc(l_dcsdp,work_dcsdp,info) - call psb_realloc(n_col,ipt,info) - if(info /= psb_no_err_) then - info=4010 - char_err='psrealloc' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - end if - - if (ipsize == n_col) then - do i=1, n_col - ipt(i) = iperm(i) - enddo - else - do i=1, n_row - ipt(i) = iperm(i) - enddo - do i=n_row+1,n_col - ipt(i) = i - enddo - endif - ! crossed fingers..... - ! fix glob_to_loc/loc_to_glob mappings, then indices lists - ! hmm, maybe we should just move all of this onto a different level, - ! have a specialized subroutine, and do it in the solver context???? - call zcsrp(trans,n_row,n_col,a%fida,a%descra,a%ia1,a%ia2,a%infoa,& - & ipt,work_dcsdp,size(work_dcsdp),info) - if(info /= psb_no_err_) then - info=4010 - char_err='dcsrp' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - end if - - deallocate(ipt,work_dcsdp,stat=info) - if(info /= psb_no_err_) then - info=4010 - char_err='Deallocate' - call psb_errpush(info,name,a_err=char_err) - goto 9999 - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zcsrp diff --git a/base/serial/psb_zcsrws.f90 b/base/serial/psb_zcsrws.f90 deleted file mode 100644 index 57d55f978..000000000 --- a/base/serial/psb_zcsrws.f90 +++ /dev/null @@ -1,105 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcsrws.f90 -! Subroutine: -! Arguments: - -subroutine psb_zcsrws(rw,a,info,trans) - use psb_spmat_type - use psb_error_mod - implicit none - - type(psb_zspmat_type) :: a - complex(psb_dpk_), allocatable :: rw(:) - integer :: info - character, optional :: trans - - Interface - subroutine zcsrws(trans,m,n,fida,descra,a,ia1,ia2,& - & infoa,rowsum,ierror) - use psb_const_mod - integer, intent(in) :: m,n - integer, intent(out) :: ierror - complex(psb_dpk_), intent(in) :: a(*) - complex(psb_dpk_), intent(out) :: rowsum(*) - integer, intent(in) :: ia1(*), ia2(*), infoa(*) - character, intent(in) :: descra*11,fida*5,trans*1 - end subroutine zcsrws - end interface - - character :: trans_ - integer :: m,k,err_act - character(len=20) :: name - - name='psb_zcsrws' - info = 0 - call psb_erractionsave(err_act) - - if (present(trans)) then - trans_ = trans - else - trans_ = 'N' - endif - - if (trans_=='N') then - m = a%m - k = a%k - else - k = a%m - m = a%k - end if - - if (size(rw) < m) then - call psb_realloc(m,rw,info) - if (info /= 0) then - info = 4000 - call psb_errpush(info,name) - goto 9999 - end if - end if - - call zcsrws(trans,m,k,a%fida,a%descra,& - & a%aspk,a%ia1,a%ia2,a%infoa,rw,info) - - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zcsrws diff --git a/base/serial/psb_zcssm.f90 b/base/serial/psb_zcssm.f90 deleted file mode 100644 index 43e9a66ec..000000000 --- a/base/serial/psb_zcssm.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcssm.f90 -! Subroutine: -! Arguments: - -subroutine psb_zcssm(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type, psb_protect_name => psb_zcssm - use psb_error_mod - implicit none - - class(psb_zspmat_type) :: t - complex(psb_dpk_) :: alpha, beta, b(:,:), c(:,:) - integer :: info - character, optional :: trans, unitd - complex(psb_dpk_), optional, target :: d(:) - - complex(psb_dpk_), allocatable :: work(:) - complex(psb_dpk_), pointer :: ddl(:) - character :: lt, lu - integer :: iwsz,m,n,lb,lc,err_act - character(len=20) :: name - - name='psb_zcssm' - info = 0 - call psb_erractionsave(err_act) - - - if (present(trans)) then - lt = trans - else - lt = 'N' - endif - if (present(unitd)) then - lu = unitd - else - lu = 'U' - endif - if (present(d)) then - ddl => d - else - allocate(ddl(1)) - endif - - m = t%m - n = min(size(b,2),size(c,2)) - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call zcssm(lt,m,n,alpha,lu,ddl,& - & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - if (.not.present(d)) then - deallocate(ddl) - endif - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_zcssm diff --git a/base/serial/psb_zcssv.f90 b/base/serial/psb_zcssv.f90 deleted file mode 100644 index 7a89ae40c..000000000 --- a/base/serial/psb_zcssv.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zcssv.f90 -! Subroutine: -! Arguments: - -subroutine psb_zcssv(alpha,t,b,beta,c,info,trans,unitd,d) - use psb_spmat_type, psb_protect_name => psb_zcssv - use psb_error_mod - implicit none - - class(psb_zspmat_type) :: t - complex(psb_dpk_) :: alpha, beta, b(:), c(:) - integer :: info - character, optional :: trans, unitd - complex(psb_dpk_), optional, target :: d(:) - - complex(psb_dpk_), allocatable :: work(:) - complex(psb_dpk_), pointer :: ddl(:) - character :: lt, lu - integer :: iwsz,m,n,lb,lc,err_act - character(len=20) :: name - - name='psb_zcssv' - info = 0 - call psb_erractionsave(err_act) - - - if (present(trans)) then - lt = trans - else - lt = 'N' - endif - if (present(unitd)) then - lu = unitd - else - lu = 'U' - endif - if (present(d)) then - ddl => d - else - allocate(ddl(1)) - endif - - m = t%m - n = 1 - lb = size(b,1) - lc = size(c,1) - iwsz = 2*m*n - allocate(work(iwsz)) - - call zcssm(lt,m,n,alpha,lu,ddl,& - & t%pl,t%fida,t%descra,t%aspk,t%ia1,t%ia2,t%infoa,t%pr,& - & b,lb,beta,c,lc,work,iwsz,info) - - if (.not.present(d)) then - deallocate(ddl) - endif - deallocate(work) - call psb_erractionrestore(err_act) - - if(info /= 0) then - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - end if - - return - -end subroutine psb_zcssv diff --git a/base/serial/psb_zfixcoo.f90 b/base/serial/psb_zfixcoo.f90 deleted file mode 100644 index 4b0152a8d..000000000 --- a/base/serial/psb_zfixcoo.f90 +++ /dev/null @@ -1,269 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zfixcoo.f90 -! Subroutine: -! Arguments: - -Subroutine psb_zfixcoo(a,info,idir) - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zfixcoo - use psb_ip_reord_mod - use psb_error_mod - implicit none - - !....Parameters... - Type(psb_zspmat_type), intent(inout) :: A - Integer, intent(out) :: info - integer, intent(in), optional :: idir - - integer, allocatable :: iaux(:) - !locals - Integer :: nza, nzl,iret,idir_, dupl_ - integer :: i,j, irw, icl, err_act - integer :: debug_level, debug_unit - character(len=20) :: name = 'psb_fixcoo' - - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': start ',& - & size(a%ia1),size(a%ia2) - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) 'Fixcoo Invalid input ',a%fida - info = -1 - return - end if - if (present(idir)) then - idir_ = idir - else - idir_ = 0 - endif - - nza = psb_sp_getifld(psb_nnz_,a,info) - if (nza < 2) return - - dupl_ = psb_sp_getifld(psb_dupl_,a,info) - - allocate(iaux(nza+2),stat=info) - if (info /= 0) return - - select case(idir_) - - case(0) ! Row major order - - call msort_up(nza,a%ia1(1),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nza,a%aspk,a%ia1,a%ia2,iaux) - i = 1 - j = i - do while (i <= nza) - do while ((a%ia1(j) == a%ia1(i))) - j = j+1 - if (j > nza) exit - enddo - nzl = j - i - call msort_up(nzl,a%ia2(i),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,a%aspk(i:i+nzl-1),& - & a%ia1(i:i+nzl-1),a%ia2(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = a%ia1(i) - icl = a%ia2(i) - j = 1 - - select case(dupl_) - case(psb_dupl_ovwrt_) - - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_add_) - - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - call psb_errpush(130,name) - goto 9999 - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - end select - - - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - - case(1) ! Col major order - - call msort_up(nza,a%ia2(1),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nza,a%aspk,a%ia1,a%ia2,iaux) - i = 1 - j = i - do while (i <= nza) - do while ((a%ia2(j) == a%ia2(i))) - j = j+1 - if (j > nza) exit - enddo - nzl = j - i - call msort_up(nzl,a%ia1(i),iaux(1),iret) - if (iret == 0) & - & call psb_ip_reord(nzl,a%aspk(i:i+nzl-1),& - & a%ia1(i:i+nzl-1),a%ia2(i:i+nzl-1),iaux) - i = j - enddo - - i = 1 - irw = a%ia1(i) - icl = a%ia2(i) - j = 1 - - - select case(dupl_) - case(psb_dupl_ovwrt_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_add_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - a%aspk(i) = a%aspk(i) + a%aspk(j) - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - - case(psb_dupl_err_) - do - j = j + 1 - if (j > nza) exit - if ((a%ia1(j) == irw).and.(a%ia2(j) == icl)) then - call psb_errpush(130,name) - goto 9999 - else - i = i+1 - a%aspk(i) = a%aspk(j) - a%ia1(i) = a%ia1(j) - a%ia2(i) = a%ia2(j) - irw = a%ia1(i) - icl = a%ia2(i) - endif - enddo - end select - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end second loop' - case default - write(debug_unit,*) trim(name),': unknown direction ',idir_ - end select - - call psb_sp_setifld(psb_isrtdcoo_,psb_srtd_,a,info) - call psb_sp_setifld(i,psb_nnz_,a,info) - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - call psb_sp_setifld(psb_upd_srch_,psb_upd_,a,info) - - deallocate(iaux) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_zfixcoo diff --git a/base/serial/psb_zgelp.f90 b/base/serial/psb_zgelp.f90 deleted file mode 100644 index 78694dcc3..000000000 --- a/base/serial/psb_zgelp.f90 +++ /dev/null @@ -1,250 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zgelp.f90 -! -! -! Subroutine: psb_zgelp -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:,:). -! info - integer. Return code. -subroutine psb_zgelp(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_zgelp - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_dpk_), intent(inout) :: x(:,:) - integer, intent(in) :: iperm(:) - integer, intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer :: ictxt - complex(psb_dpk_),allocatable :: dtemp(:) - integer, allocatable :: itemp(:) - integer :: int_err(5), i1sz, i2sz, err_act - real(psb_dpk_),parameter :: one=1 - logical, parameter :: debug=.false. - - interface - subroutine zgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(psb_dpk_), intent(inout) :: b(ldb,*), work(*) - integer, intent(in) :: p(*) - end subroutine zgelp - end interface - - character(len=20) :: name, ch_err - name = 'psb_zgelp' - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - i1sz = size(x,dim=1) - i2sz = size(x,dim=2) - - if (debug) write(*,*) 'gelp: ',i1sz,i2sz - allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - - call zgelp(trans,i1sz,i2sz,itemp,x,i1sz,dtemp,i1sz,info) - if(info /= 0) then - info=4010 - ch_err='zgelp' - call psb_errpush(info,name,a_err=ch_err) - end if - - deallocate(dtemp,itemp) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_zgelp - - - -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! -! WARNING: This routine should be changed and moved to the serial part -! i.e. taking out the descriptor. -! -! -! Subroutine: psb_zgelpv -! Apply a left permutation to a dense matrix -! -! Arguments: -! trans - character. -! iperm - integer. -! x - real, dimension(:). -! info - integer. Return code. -subroutine psb_zgelpv(trans,iperm,x,info) - use psb_serial_mod, psb_protect_name => psb_zgelpv - use psb_const_mod - use psb_error_mod - implicit none - - complex(psb_dpk_), intent(inout) :: x(:) - integer, intent(in) :: iperm(:) - integer, intent(out) :: info - character, intent(in) :: trans - - ! local variables - integer :: ictxt - integer :: int_err(5), i1sz, err_act - complex(psb_dpk_),allocatable :: dtemp(:) - integer, allocatable :: itemp(:) - real(psb_dpk_),parameter :: one=1 - logical, parameter :: debug=.false. - - interface zgelp - subroutine zgelp(trans,m,n,p,b,ldb,work,lwork,ierror) - use psb_const_mod - integer, intent(in) :: ldb, m, n, lwork - integer, intent(out) :: ierror - character, intent(in) :: trans - complex(psb_dpk_), intent(inout) :: b(*), work(*) - integer, intent(in) :: p(*) - end subroutine zgelp - end interface - - character(len=20) :: name, ch_err - name = 'psb_zgelpv' - - if(psb_get_errstatus() /= 0) return - info=0 - call psb_erractionsave(err_act) - - i1sz = size(x) - - - if (debug) write(*,*) 'gelp: ',i1sz - allocate(dtemp(i1sz),itemp(size(iperm)),stat=info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - itemp(:) = iperm(:) - - if (.not.psb_isaperm(i1sz,itemp)) then - info = 70 - int_err(1) = 1 - call psb_errpush(info,name,i_err=int_err) - goto 9999 - endif - - - call zgelp(trans,i1sz,1,itemp,x,i1sz,dtemp,i1sz,info) - if(info /= 0) then - info=4010 - ch_err='zgelp' - call psb_errpush(info,name,a_err=ch_err) - end if - - deallocate(dtemp) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - - if (err_act == psb_act_ret_) then - return - else - call psb_error(ictxt) - end if - return - -end subroutine psb_zgelpv - diff --git a/base/serial/psb_zipcoo2csc.f90 b/base/serial/psb_zipcoo2csc.f90 deleted file mode 100644 index 99164ee3e..000000000 --- a/base/serial/psb_zipcoo2csc.f90 +++ /dev/null @@ -1,221 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zipcoo2csc.f90 -! Subroutine: -! Arguments: - -subroutine psb_zipcoo2csc(a,info,clshr) - use psb_spmat_type - use psb_const_mod - use psb_serial_mod, psb_protect_name => psb_zipcoo2csc - use psb_error_mod - use psb_string_mod - use psb_realloc_mod - implicit none - - !....Parameters... - Type(psb_zspmat_type), intent(inout) :: A - Integer, intent(out) :: info - logical, optional :: clshr - - integer, allocatable :: iaux(:), itemp(:) - !locals - logical :: clshr_ - Integer :: nza, i,j, idl,err_act,nc,icl - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name - - name='psb_ipcoo2csc' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if(debug_level >= psb_debug_serial_) write(debug_unit,*) & - & trim(name),': start',a%fida,a%m - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) trim(name),' Invalid input ',a%fida - info = -1 - call psb_errpush(info,name) - goto 9999 - end if - if (present(clshr)) then - clshr_ = clshr - else - clshr_ = .false. - end if - - call psb_fixcoo(a,info,idir=1) - if (info == 0) then - nc = a%k - nza = a%infoa(psb_nnz_) - allocate(iaux(max(nc+1,1)),stat=info) - end if - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nc+1,1),0,0,0,0/)) - goto 9999 - end if - if(debug_level >= psb_debug_serial_) write(debug_unit,*) trim(name),& - & ': out of fixcoo',nza,nc,size(a%ia2),size(iaux) - - call psb_move_alloc(a%ia2,itemp,info) - if (info == 0) call psb_move_alloc(iaux,a%ia2,info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='psb_move_alloc') - goto 9999 - end if - - ! - ! This routine can be used in two modes: - ! 1. Normal: just look at the col indices and trust them. This - ! implies putting in empty cols where needed. In this case you - ! can get in trouble if A%M < A%IA1(NZA) - ! 2. Shrink mode: disregard the actual value of the col indices, - ! just treat them as ident markers. In this case you can get in - ! trouble when the number of distinct col indices is greater - ! than A%M - ! - ! - - a%ia2(1) = 1 - - if (nza <= 0) then - do i=1,nc - a%ia2(i+1) = a%ia2(i) - end do - else - - if (clshr_) then - - j = 1 - i = 1 - icl = itemp(j) - - do j=1, nza - if (itemp(j) /= icl) then - a%ia2(i+1) = j - icl = itemp(j) - i = i + 1 - if (i>nc) then - write(debug_unit,*) trim(name),': CLSHR=.true. : ',& - & i, nc,' Expect trouble!' - exit - end if - endif - enddo -! write(debug_unit,*) 'Exit from loop',j,nza,i - do - if (i>=nc+1) exit - a%ia2(i+1) = j - i = i + 1 - end do - - else - - if (nc < itemp(nza)) then - write(debug_unit,*) trim(name),': CLSHR=.false. : ',& - &nc,itemp(nza),' Expect trouble!' - end if - - - j = 1 - i = 1 - icl = itemp(j) - - outer: do - inner: do - if (i >= icl) exit inner - if (i>nc) then - write(debug_unit,*) trim(name),& - & 'strange situation: i>nc ',i,nc,j,nza,icl,idl - exit outer - end if - a%ia2(i+1) = a%ia2(i) - i = i + 1 - end do inner - j = j + 1 - if (j > nza) exit - if (itemp(j) /= icl) then - if (i>nc) then - write(debug_unit,*) trim(name), & - &'Strange situation: ',i,nc,size(a%ia2),& - & nza,j,itemp(j) - end if - a%ia2(i+1) = j - icl = itemp(j) - i = i + 1 - endif - if (i>nc) exit - enddo outer - ! - ! Cleanup empty cols at the end - ! - if (j /= (nza+1)) then - write(debug_unit,*) trim(name),': Problem from loop :',j,nza,itemp(j) - endif - do - if (i>nc) exit - a%ia2(i+1) = j - i = i + 1 - end do - - endif - - end if - -!!$ write(debug_unit,*) 'IPcoo2csc end loop ',i,nc,a%ia2(nc+1),nza - a%fida='CSC' - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp,stat=info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='deallocate') - goto 9999 - end if - if(debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_zipcoo2csc diff --git a/base/serial/psb_zipcoo2csr.f90 b/base/serial/psb_zipcoo2csr.f90 deleted file mode 100644 index e97a52ccd..000000000 --- a/base/serial/psb_zipcoo2csr.f90 +++ /dev/null @@ -1,213 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zipcoo2csr.f90 -! Subroutine: -! Arguments: - -subroutine psb_zipcoo2csr(a,info,rwshr) - use psb_spmat_type - use psb_const_mod - use psb_realloc_mod - use psb_serial_mod, only : psb_fixcoo - use psb_error_mod - use psb_string_mod - implicit none - - !....Parameters... - Type(psb_zspmat_type), intent(inout) :: A - Integer, intent(out) :: info - logical, optional :: rwshr - - integer, allocatable :: iaux(:), itemp(:) - !locals - logical :: rwshr_ - Integer :: nza, nr, i,j,irw, idl,err_act - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name - - name='psb_ipcoo2csr' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': start',a%fida,a%m - if (psb_toupper(a%fida) /= 'COO') then - write(debug_unit,*) trim(name),': Invalid input ',a%fida - info = -1 - call psb_errpush(info,name) - goto 9999 - end if - if (present(rwshr)) then - rwshr_ = rwshr - else - rwshr_ = .false. - end if - - call psb_fixcoo(a,info) - nr = a%m - nza = a%infoa(psb_nnz_) - allocate(iaux(max(nr+1,1)),stat=info) - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nr+1,1),0,0,0,0/)) - goto 9999 - end if - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & ': out of fixcoo',nza,nr,size(a%ia2),size(iaux) - - call psb_move_alloc(a%ia1,itemp,info) - call psb_move_alloc(a%ia2,a%ia1,info) - call psb_move_alloc(iaux,a%ia2,info) - - ! - ! This routine can be used in two modes: - ! 1. Normal: just look at the row indices and trust them. This - ! implies putting in empty rows where needed. In this case you - ! can get in trouble if A%M < A%IA1(NZA) - ! 2. Shrink mode: disregard the actual value of the row indices, - ! just treat them as ident markers. In this case you can get in - ! trouble when the number of distinct row indices is greater - ! than A%M - ! - ! - - a%ia2(1) = 1 - - if (nza <= 0) then - do i=1,nr - a%ia2(i+1) = a%ia2(i) - end do - else - - if (rwshr_) then - - - j = 1 - i = 1 - irw = itemp(j) - - do j=1, nza - if (itemp(j) /= irw) then - a%ia2(i+1) = j - irw = itemp(j) - i = i + 1 - if (i>nr) then - write(debug_unit,*) trim(name),': RWSHR=.true. : ',& - & i, nr,' Expect trouble!' - exit - end if - endif - enddo - do - if (i>=nr+1) exit - a%ia2(i+1) = j - i = i + 1 - end do - - else - - if (nr < itemp(nza)) then - write(debug_unit,*) trim(name),': RWSHR=.false. : ',& - &nr,itemp(nza),' Expect trouble!' - info = 12 - end if - - - j = 1 - i = 1 - irw = itemp(j) - - outer: do - inner: do - if (i >= irw) exit inner - if (i>nr) then - write(debug_unit,*) trim(name),& - & 'Strange situation: i>nr ',i,nr,j,nza,irw,idl - exit outer - end if - a%ia2(i+1) = a%ia2(i) - i = i + 1 - end do inner - j = j + 1 - if (j > nza) exit - if (itemp(j) /= irw) then - a%ia2(i+1) = j - irw = itemp(j) - i = i + 1 - endif - if (i>nr) exit - enddo outer - ! - ! Cleanup empty rows at the end - ! - if (j /= (nza+1)) then - write(debug_unit,*) trim(name),': Problem from loop :',j,nza - info = 13 - endif - do - if (i>nr) exit - a%ia2(i+1) = j - i = i + 1 - end do - - endif - - end if - - a%fida='CSR' - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp,stat=info) - if (info /= 0) then - info=4010 - call psb_errpush(info,name,a_err='deallocate') - goto 9999 - end if - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),': end' - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_zipcoo2csr diff --git a/base/serial/psb_zipcsr2coo.f90 b/base/serial/psb_zipcsr2coo.f90 deleted file mode 100644 index 868fbdc40..000000000 --- a/base/serial/psb_zipcsr2coo.f90 +++ /dev/null @@ -1,102 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zipcsr2coo.f90 -! Subroutine: -! Arguments: - -Subroutine psb_zipcsr2coo(a,info) - use psb_spmat_type - use psb_const_mod - use psb_error_mod - use psb_string_mod - use psb_realloc_mod - use psb_serial_mod, psb_protect_name => psb_zipcsr2coo - implicit none - - !....Parameters... - Type(psb_zspmat_type), intent(inout) :: A - Integer, intent(out) :: info - - !locals - Integer :: nza, nr - integer :: i,j,err_act - integer, allocatable :: iaux(:), itemp(:) - character(len=20) :: name='psb_zipcsr2coo' - - info = 0 - call psb_erractionsave(err_act) - - if (psb_toupper(a%fida) /= 'CSR') then - info = 5 - call psb_errpush(info,name) - goto 9999 - end if - - nr = a%m - nza = a%ia2(nr+1) - 1 - allocate(iaux(max(nza,1)),stat=info) - if (info /= 0) then - info=4025 - call psb_errpush(info,name,a_err='integer',i_err=(/max(nza,1),0,0,0,0/)) - goto 9999 - end if - - call psb_move_alloc(a%ia2,itemp,info) - call psb_move_alloc(a%ia1,a%ia2,info) - call psb_move_alloc(iaux,a%ia1,info) - - do i=1, nr - do j=itemp(i),itemp(i+1)-1 - a%ia1(j) = i - end do - end do - - a%fida='COO' - a%infoa(psb_nnz_) = nza - a%infoa(psb_srtd_) = psb_isrtdcoo_ - a%infoa(psb_upd_) = psb_upd_srch_ - - deallocate(itemp) - call psb_fixcoo(a,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end Subroutine psb_zipcsr2coo diff --git a/base/serial/psb_zneigh.f90 b/base/serial/psb_zneigh.f90 deleted file mode 100644 index a4644a1d8..000000000 --- a/base/serial/psb_zneigh.f90 +++ /dev/null @@ -1,121 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zneigh.f90 -! Subroutine: -! Arguments: - -subroutine psb_zneigh(a,idx,neigh,n,info,lev) - - use psb_realloc_mod - use psb_const_mod - use psb_spmat_type - use psb_serial_mod, psb_protect_name => psb_zneigh - implicit none - - - type(psb_zspmat_type), intent(in) :: a ! the sparse matrix - integer, intent(in) :: idx ! the index whose neighbours we want to find - integer, intent(out) :: n, info ! the number of neighbours and the info - integer, allocatable :: neigh(:) ! the neighbours - integer, optional, intent(in) :: lev ! level of neighbours to find - - integer :: lev_, i, nl, ifl,ill,& - & n1, err_act, nn, nidx,ntl - character(len=20) :: name - integer, allocatable :: ia(:), ja(:) - complex(psb_dpk_), allocatable :: val(:) - - name='psb_zneigh' - info = 0 - call psb_erractionsave(err_act) - - n = 0 - info = 0 - if(present(lev)) then - lev_ = lev - else - lev_=1 - end if - - call psb_sp_getrow(idx,a,n,ia,ja,val,info) - if (info == 0) call psb_realloc(n,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(1:n) = ja(1:n) - ifl = 1 - ill = n - - - do nl = 2, lev_ - n1 = ill - ifl + 1 - call psb_ensure_size(ill+n1*n1,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - ntl = 0 - do i=ifl,ill - nidx=neigh(i) - if ((nidx /= idx).and.(nidx > 0).and.(nidx <= a%m)) then - call psb_sp_getrow(nidx,a,nn,ia,ja,val,info) - if (info==0) call psb_ensure_size(ill+ntl+nn,neigh,info) - if (info /= 0) then - call psb_errpush(4000,name) - goto 9999 - end if - neigh(ill+ntl+1:ill+ntl+nn)=ja(1:nn) - ntl = ntl+nn - end if - end do - call psb_msort_unique(neigh(ill+1:ill+ntl),nn) - ifl = ill + 1 - ill = ill + nn - end do - call imsru(ill,neigh,psb_sort_up_,nn) - n = nn - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_zneigh - diff --git a/base/serial/psb_zspclip.f90 b/base/serial/psb_zspclip.f90 deleted file mode 100644 index 596d22ee0..000000000 --- a/base/serial/psb_zspclip.f90 +++ /dev/null @@ -1,157 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspclip.f90 -! Subroutine: psb_zspclip -! Creates a "clipped" copy of input matrix A. Output is always in COO. -! Arguments: - -!***************************************************************************** -!* * -!***************************************************************************** -subroutine psb_zspclip(a,b,info,imin,imax,jmin,jmax,rscale,cscale) - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zspclip - implicit none - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(out) :: b - integer, intent(out) :: info - integer, intent(in), optional :: imin,imax,jmin,jmax - logical, intent(in), optional :: rscale,cscale - - integer :: err_act - character(len=20) :: name - integer :: imin_,imax_,jmin_,jmax_ - logical :: rscale_,cscale_ - integer :: sizeb, nzb, mb, kb, ifst, ilst, nrt, nzt, i, j - integer, parameter :: irbk=40 - - name='psb_zsp_clip' - info = 0 - call psb_erractionsave(err_act) - call psb_set_erraction(0) - - call psb_nullify_sp(b) - - - if (present(imin)) then - imin_ = imin - else - imin_ = 1 - endif - if (present(imax)) then - imax_ = imax - else - imax_ = a%m - endif - if (present(jmin)) then - jmin_ = jmin - else - jmin_ = 1 - endif - if (present(jmax)) then - jmax_ = jmax - else - jmax_ = a%k - endif - if (present(rscale)) then - rscale_ = rscale - else - rscale_ = .true. - endif - if (present(cscale)) then - cscale_ = cscale - else - cscale_ = .true. - endif - - if (rscale_) then - mb = imax_ - imin_ +1 - else - mb = a%m ! Should this be imax_ ?? - endif - if (cscale_) then - kb = jmax_ - jmin_ +1 - else - kb = a%k ! Should this be jmax_ ?? - endif - - - sizeb = psb_sp_get_nnzeros(a) - call psb_sp_all(mb,kb,b,sizeb,info) - b%fida = 'COO' - b%descra = a%descra - nzb = 0 - do i=imin_, imax_, irbk - nrt = min(irbk,imax_-i+1) - ifst = i - ilst = ifst + nrt - 1 - call psb_sp_getrow(ifst,a,nzt,b%ia1,b%ia2,b%aspk,info,& - & lrw=ilst, append=.true.,nzin=nzb) - do j=nzb+1,nzb+nzt - if ((jmin_ <= b%ia2(j)).and.(b%ia2(j) <= jmax_)) then - nzb = nzb + 1 - b%aspk(nzb) = b%aspk(j) - b%ia1(nzb) = b%ia1(j) - b%ia2(nzb) = b%ia2(j) - end if - end do - - end do - b%infoa(psb_nnz_) = nzb - - if (rscale_) then - do i=1, nzb - b%ia1(i) = b%ia1(i) - imin_ + 1 - end do - end if - if (cscale_) then - do i=1, nzb - b%ia2(i) = b%ia2(i) - jmin_ + 1 - end do - end if - call psb_fixcoo(b,info) - call psb_sp_trim(b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zspclip - diff --git a/base/serial/psb_zspcnv.f90 b/base/serial/psb_zspcnv.f90 deleted file mode 100644 index fc5501017..000000000 --- a/base/serial/psb_zspcnv.f90 +++ /dev/null @@ -1,573 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspcnv.f90 -! -! Subroutine: psb_zspcnv2 -! This subroutine converts the storage format of a matrix. -! -! Arguments: -! -! a - type(psb_spmat_type), input The input matrix to be converted. -! b - type(psb_spmat_type), output The assembled output matrix. -! info - integer. Return code -! afmt - character, optional The desired storage format -! -subroutine psb_zspcnv2(a, b,info,afmt,upd,dupl) - use psb_const_mod - use psb_error_mod - use psb_spmat_type - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zspcnv2 - implicit none - !....Parameters... - Type(psb_zspmat_type), intent(in) :: A - Type(psb_zspmat_type), intent(out) :: B - Integer, intent(out) :: info - Integer, intent(in), optional :: upd,dupl - character(len=*), optional, intent(in) :: afmt - - !...Locals... - complex(psb_dpk_) :: d(1) - complex(psb_dpk_), allocatable :: work(:) - type(psb_zspmat_type) :: temp_a - Integer :: nzr, ntry, ifc_, ia1_size,& - & ia2_size, aspk_size,size_req,n_row,n_col,upd_,dupl_ - integer :: err_act - character :: check_,trans_,unitd_ - character(len=5) :: afmt_ - Integer, Parameter :: maxtry=8 - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - - name='psb_spcnv2' - info = 0 - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - ntry=0 - - ifc_ = 2 - - - check_ = 'N' - trans_ = 'N' - unitd_ = 'U' - allocate(work(max(size(a%ia1),size(a%ia2))+a%m+1000),stat=info) - - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - end if - - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,b,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,b,info) - end if - if (present(afmt)) then - afmt_ = psb_toupper(afmt) - else - afmt_ = psb_fidef_ - end if - - upd_ = psb_sp_getifld(psb_upd_,b,info) - select case(upd_) - case(psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,b,info) - end select - - dupl_ = psb_sp_getifld(psb_dupl_,b,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,b,info) - end select - - ! ...matrix conversion... - b%m=a%m - b%k=a%k - b%fida=psb_toupper(afmt_) - size_req = psb_sp_get_nnzeros(a) - ! - n_row=b%m - n_col=b%k - call psb_cest(afmt_,n_row,n_col,size_req,& - & ia1_size, ia2_size, aspk_size, upd_,info) - b%fida=afmt_ - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_cest' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - if (.not.allocated(b%aspk).or.& - &.not.allocated(b%ia1).or.& - &.not.allocated(b%ia2).or.& - &.not.allocated(b%pl).or.& - &.not.allocated(b%pr)) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - else if ((size(b%aspk) < aspk_size) .or.& - &(size(b%ia1) < ia1_size) .or.& - &(size(b%ia2) < ia2_size) .or.& - &(size(b%pl) < b%m) .or.& - &(size(b%pr) < b%k )) then - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - endif - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_reall' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - b%pl(:) = 0 - b%pr(:) = 0 - - b%descra = a%descra - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': size_req 1:',& - & size_req, trans_,upd_,dupl_,b%fida,b%descra - - select case (psb_toupper(a%fida)) - - case ('CSR') - - select case (psb_toupper(b%fida)) - - case ('CSR') - - call zcrcr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - - if (info/=0) then - info=4010 - ch_err='dcrcr' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - case ('JAD') - - !...converting to JAD - !...output matrix may not be big enough - do - - call zcrjd(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info /= 0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - endif - - ntry = ntry + 1 - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),' On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(debug_unit,*) trim(name),& - & ' Tried reallocating for DCRJAD for ',maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - call psb_cest(afmt_,n_row,n_col,nzr,& - & ia1_size, ia2_size, aspk_size, upd_,info) - call psb_sp_reall(b,ia1_size,ia2_size,aspk_size,info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - if (info/=0) then - call psb_errpush(info,name) - goto 9999 - end if - - case ('COO') - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),' Calling CRCO ',a%descra - call zcrco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrco') - goto 9999 - end if - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - case ('COO','COI') - - select case (psb_toupper(b%fida)) - - case ('CSR') - - call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - case ('JAD') - - call psb_sp_all(temp_a, size(b%ia1),size(b%ia2),size(b%aspk),info) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - temp_a%m = a%m - temp_a%k = a%k - temp_a%infoa=b%infoa - !...Dirty trick: converting to CSR and then to JAD - - call zcocr(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia2, a%ia1, a%infoa, temp_a%pl, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, temp_a%pr, & - & size(temp_a%aspk), size(temp_a%ia1),& - & size(temp_a%ia2), work, 2*size(work), info) - - if (info/=0) then - call psb_errpush(4010,name,a_err='dcocr') - goto 9999 - end if - - do - call zcrjd(trans_, temp_a%m, temp_a%k, unitd_, d, temp_a%descra, & - & temp_a%aspk, temp_a%ia1, temp_a%ia2, temp_a%infoa, & - & b%pl, b%descra, b%aspk, b%ia1, b%ia2, b%infoa, b%pr, & - & size(b%aspk), size(b%ia1),& - & size(b%ia2), work, size(work), nzr, info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcrjd') - goto 9999 - end if - - ntry = ntry + 1 - if (debug_level >= psb_debug_serial_) then - write(debug_unit,*) trim(name),' On out from dcrjad ',nzr,info - end if - if (nzr == 0) exit - if (ntry > maxtry ) then - write(debug_unit,*) trim(name),' Tried reallocating for DCRJAD for ',& - & maxtry,': giving up now.' - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - call psb_sp_reall(b,nzr,info,ifc=ifc_) - if (info /= 0) then - info=2040 - call psb_errpush(info,name) - goto 9999 - endif - - end do - - case ('COO') - - call zcoco(trans_, a%m, a%k, unitd_, d, a%descra, a%aspk,& - & a%ia1, a%ia2, a%infoa, b%pl, b%descra, b%aspk, b%ia1,& - & b%ia2, b%infoa, b%pr, size(b%aspk), size(b%ia1),& - & size(b%ia2), work, 2*size(work), info) - if (info/=0) then - call psb_errpush(4010,name,a_err='dcoco') - goto 9999 - end if - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - end select - - case default - info=4010 - call psb_errpush(info,name) - goto 9999 - - end select - - if (psb_sp_getifld(psb_upd_,b,info) /= psb_upd_perm_) then - call psb_sp_trim(b,info) - end if - - - call psb_sp_setifld(psb_spmat_asb_,psb_state_,b,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zspcnv2 - - -! -! Subroutine: psb_zspcnv1 -! This subroutine converts in place the storage format of a matrix. -! -! Arguments: -! -! a - type(psb_spmat_type), inout The input matrix to be converted. -! info - integer. Return code -! afmt - character, optional The desired storage format -! -subroutine psb_zspcnv1(a, info, afmt, upd, dupl) - - use psb_spmat_type - use psb_regen_mod - use psb_serial_mod, psb_protect_name => psb_zspcnv1 - use psb_const_mod - use psi_mod - use psb_error_mod - use psb_string_mod - !use psb_penv_mod - - implicit none - - - !...Parameters.... - type(psb_zspmat_type), intent (inout) :: a - integer, intent(out) :: info - integer,optional, intent(in) :: dupl, upd - character(len=*), optional, intent(in) :: afmt - - integer :: int_err(5) - type(psb_zspmat_type) :: atemp - integer :: err_act - integer :: spstate - integer :: upd_, dupl_ - integer :: debug_level, debug_unit - character(len=20) :: name, ch_err - logical :: inplace - - info = 0 - int_err(1)=0 - name = 'psb_spcnv' - call psb_erractionsave(err_act) - debug_unit = psb_get_debug_unit() - debug_level = psb_get_debug_level() - - if (present(upd)) then - call psb_sp_setifld(upd,psb_upd_,a,info) - end if - if (present(dupl)) then - call psb_sp_setifld(dupl,psb_dupl_,a,info) - end if - - upd_ = psb_sp_getifld(psb_upd_,a,info) - select case(upd_) - case(psb_upd_srch_,psb_upd_perm_) - ! Legal value, do nothing - case default - ! Fix bad value - upd_ = psb_upd_dflt_ - call psb_sp_setifld(upd_,psb_upd_,a,info) - end select - - dupl_ = psb_sp_getifld(psb_dupl_,a,info) - select case(dupl_) - case(psb_dupl_ovwrt_,psb_dupl_add_,psb_dupl_err_) - ! Legal value, do nothing - case default - ! Fix bad value - dupl_ = psb_dupl_def_ - call psb_sp_setifld(dupl_,psb_dupl_,a,info) - end select - - - spstate = psb_sp_getifld(psb_state_,a,info) - if (info /= 0) then - goto 9999 - endif - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),': Sparse matrix state:',& - & spstate,psb_spmat_bld_,psb_spmat_upd_ - if (spstate /= psb_spmat_upd_) then - ! Should we first figure out if we can do it in place? - if (debug_level >= psb_debug_serial_) & - & write(debug_unit,*) trim(name),& - & ': Update:',upd_,psb_upd_srch_,psb_upd_perm_ - inplace = .false. - if (upd_ == psb_upd_srch_) then - if (present(afmt)) then - select case (psb_toupper(a%fida)) - case('COO') - select case(psb_toupper(afmt)) - case('COO') - call psb_fixcoo(a,info) - inplace = .true. - case('CSR') - call psb_ipcoo2csr(a,info) - inplace = .true. - case('CSC') - call psb_ipcoo2csc(a,info) - inplace = .true. - end select - case('CSR') - select case(psb_toupper(afmt)) - case('COO') - call psb_ipcsr2coo(a,info) - inplace = .true. - end select - end select - end if - if (inplace) then - if (info == 0) call psb_sp_trim(a,info) - if (info /= 0) then - info=4010 - ch_err='inplace cnv' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - call psb_erractionrestore(err_act) - return - end if - end if - - call psb_sp_clone(a,atemp,info) - if(info /= psb_no_err_) then - info=4010 - ch_err='psb_sp_clone' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - ! convert to user requested format after the temp copy - end if - - ! Do the real conversion into the requested storage format - ! result is put in A - call psb_spcnv(atemp,a,info,afmt=afmt,upd=upd,dupl=dupl) - - if (debug_level >= psb_debug_serial_)& - & write(debug_unit, *) trim(name),& - & ': From SPCNV',info,' ',a%fida - - if (info /= psb_no_err_) then - info=4010 - ch_err='psb_csdp' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - endif - - call psb_sp_free(atemp,info) - - else if (spstate == psb_spmat_upd_) then - ! - ! Second case: we come from an update loop. - ! - select case(psb_toupper(a%fida)) - case('CSR') - call csr_regen(a,info) - case ('COO','COI') - call coo_regen(a,info) - case('JAD') - call jad_regen(a,info) - case default - info=136 - ch_err=a%fida - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (info /= psb_no_err_) then - info = 4010 - ch_err='xx_regen' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - else - - info = 600 - call psb_errpush(info,name) - goto 9999 - if (debug_level >= psb_debug_serial_)& - & write(debug_unit,*) trim(name),& - & 'Sparse matrix state:',spstate,psb_spmat_bld_,psb_spmat_upd_ - - endif - - call psb_sp_setifld(psb_spmat_asb_,psb_state_,a,info) - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zspcnv1 diff --git a/base/serial/psb_zspgetrow.f90 b/base/serial/psb_zspgetrow.f90 deleted file mode 100644 index 02bd4aa44..000000000 --- a/base/serial/psb_zspgetrow.f90 +++ /dev/null @@ -1,130 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspgetrow.f90 -! Subroutine: psb_zspgetrow -! Gets one or more rows from a sparse matrix. -! Arguments: -! irw - integer, input The row to be extracted -! a - type(psb_zspmat_type),input The sparse matrix -! nz - integer, output The number of entries -! ia(:) - integer, allocatable, inout The output row indices -! ja(:) - integer, allocatable, inout The output col indices -! val(:) - complex, allocatable,inout The coefficients -! info - integer, output Error code -! iren(:) - integer, input,optional Renumbering of indices -! lrw - integer, input,optional Extract rows irw:lrw, default lrw=irw -! append - logical, input,optional Should we append to already existing -! partial output? -! nzin - integer, input, optional If appending, how many entries were already -! occupied. -! -subroutine psb_zspgetrow(irw,a,nz,ia,ja,val,info,iren,lrw,append,nzin) - ! Output is always in COO format - use psb_spmat_type - use psb_const_mod - use psb_getrow_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zspgetrow - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer, intent(in) :: irw - integer, intent(out) :: nz - integer, allocatable, intent(inout) :: ia(:), ja(:) - complex(psb_dpk_), allocatable, intent(inout) :: val(:) - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), optional :: iren(:) - integer, intent(in), optional :: lrw, nzin - - logical :: append_ - integer :: nzin_, lrw_, irw_, err_act - character(len=20) :: name, ch_err - - name='psb_spgetrow' - info = 0 - - call psb_erractionsave(err_act) - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_=append - else - append_=.false. - endif - - - if ((append_).and.(present(nzin))) then - nzin_ = nzin - else - nzin_ = 0 - endif - - select case (psb_tolower(a%fida)) - case ('csr') - call csr_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case ('coo') - call coo_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case ('jad') - call jad_getrow(irw_,a,nz,ia,ja,val,nzin_,append_,lrw_,info,iren) - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - if (info /= 0) goto 9999 -!!$ call psb_erractionrestore(err_act) - return - -9999 continue -!!$ call psb_erractionrestore(err_act) - call psb_erractionsave(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_zspgetrow - diff --git a/base/serial/psb_zspgtblk.f90 b/base/serial/psb_zspgtblk.f90 deleted file mode 100644 index b3987fc3a..000000000 --- a/base/serial/psb_zspgtblk.f90 +++ /dev/null @@ -1,114 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspgtblk.f90 -! Subroutine: psb_zspgtblk -! Gets one or more rows from a sparse matrix. -! Arguments: -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, * -!* * -!***************************************************************************** -subroutine psb_zspgtblk(irw,a,b,info,append,iren,lrw,srt) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zspgtblk - implicit none - - type(psb_zspmat_type), intent(in) :: a - integer, intent(in) :: irw - type(psb_zspmat_type), intent(inout) :: b - integer,intent(out) :: info - logical, intent(in), optional :: append - integer, intent(in), target, optional :: iren(:) - integer, intent(in), optional :: lrw - logical, intent(in), optional :: srt - - logical :: append_,srt_ - integer :: nz,nzb, lrw_, irw_ - character(len=20) :: name - - name='psb_spgtblk' - info = 0 - - irw_ = irw - if (present(lrw)) then - lrw_ = lrw - else - lrw_ = irw - endif - if (lrw_ < irw) then - write(0,*) 'SPGTBLK input error: fixing lrw',irw,lrw_ - lrw_ = irw - end if - if (present(append)) then - append_ = append - else - append_ = .false. - endif - - if (present(srt)) then - srt_ = srt - else - srt_ = .true. - endif - - - if (append_) then - nzb = b%infoa(psb_nnz_) - else - nzb = 0 - b%m = 0 - b%k = 0 - b%descra = a%descra - endif - b%fida = 'COO' - - call psb_sp_getrow(irw,a,nz,b%ia1,b%ia2,b%aspk,info,iren=iren,& - & lrw=lrw_,append=append_,nzin=nzb) - if (info == 0) call psb_ensure_size(1,b%pl,info) - if (info == 0) call psb_ensure_size(1,b%pr,info) - if (info /= 0) return - b%pl = 0 - b%pr = 0 - b%infoa(psb_nnz_) = nzb+nz - b%m = b%m+lrw_-irw+1 - b%k = max(b%k,a%k) - if (srt_) call psb_fixcoo(b,info) - return - -end subroutine psb_zspgtblk - diff --git a/base/serial/psb_zspgtdiag.f90 b/base/serial/psb_zspgtdiag.f90 deleted file mode 100644 index 52f8f052a..000000000 --- a/base/serial/psb_zspgtdiag.f90 +++ /dev/null @@ -1,123 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspgtdiag.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* * -!***************************************************************************** -subroutine psb_zspgtdiag(a,d,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_serial_mod, psb_protect_name => psb_zspgtdiag - implicit none - - type(psb_zspmat_type), intent(in) :: a - complex(psb_dpk_), intent(inout) :: d(:) - integer, intent(out) :: info - - type(psb_zspmat_type) :: tmpa - integer :: i,j, err_act, ii, rng, irb, nrb - character(len=20) :: name, ch_err - - name='psb_zspgtdiag' - info = 0 - call psb_erractionsave(err_act) - - if (size(d) < min(a%k,a%m)) then - info=35 - call psb_errpush(info,name,i_err=(/2,size(d),0,0,0/)) - goto 9999 - end if - d(:) = 0.d0 - if (a%fida == 'CSR') then - - do i=1, min(a%m,a%k) - do j=a%ia2(i),a%ia2(i+1)-1 - if (a%ia1(j) == i) then - d(i) = a%aspk(j) - end if - end do - end do - - else if (a%fida == 'COO') then - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - if ((j==a%ia2(i)).and.(j <= min(a%k,a%m)) .and.(j>0)) then - d(j) = a%aspk(i) - endif - enddo - - else if (a%fida == 'JAD') then - - rng=min(a%m,a%k) - nrb=16 - do i=1, rng, nrb - irb=min(i+nrb-1,rng) - call psb_sp_getblk(i,a,tmpa,info,lrw=irb) - if(info /= 0) then - info=4010 - ch_err='psb_spgtblk' - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end if - - do ii=1,tmpa%infoa(psb_nnz_) - j=tmpa%ia1(ii) - if ((j==tmpa%ia2(ii)).and.(j <= rng) .and.(j>0)) then - d(j) = tmpa%aspk(ii) - endif - enddo - - end do - - end if - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zspgtdiag - diff --git a/base/serial/psb_zspscal.f90 b/base/serial/psb_zspscal.f90 deleted file mode 100644 index 9ccfad231..000000000 --- a/base/serial/psb_zspscal.f90 +++ /dev/null @@ -1,158 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspscal.f90 -! Subroutine: -! Arguments: - -!***************************************************************************** -!* * -!* * -!***************************************************************************** -subroutine psb_zspscal(a,d,info) - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - complex(psb_dpk_), intent(in) :: d(:) - - integer :: i,j, err_act - character(len=20) :: name, ch_err - - name='psb_zspscal' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_toupper(a%fida(1:3))) - case ('CSR') - - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - a%aspk(j) = a%aspk(j) * d(i) - end do - end do - - case ('COO') - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - a%aspk(i) = a%aspk(i) * d(j) - enddo - - case ('JAD') - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zspscal -subroutine psb_zspscals(a,d,info) - ! the input format - use psb_spmat_type - use psb_error_mod - use psb_const_mod - use psb_string_mod - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - complex(psb_dpk_), intent(in) :: d - - integer :: i,j, err_act - character(len=20) :: name, ch_err - - name='psb_zspscal' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_toupper(a%fida(1:3))) - case ('CSR') - - do i=1, a%m - do j=a%ia2(i),a%ia2(i+1)-1 - a%aspk(j) = a%aspk(j) * d - end do - end do - - case ('COO') - - do i=1,a%infoa(psb_nnz_) - j=a%ia1(i) - a%aspk(i) = a%aspk(i) * d - enddo - - case ('JAD') - info=135 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - case default - info=136 - ch_err=a%fida(1:3) - call psb_errpush(info,name,a_err=ch_err) - goto 9999 - end select - - call psb_erractionrestore(err_act) - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - -end subroutine psb_zspscals - diff --git a/base/serial/psb_zspsetbld.f90 b/base/serial/psb_zspsetbld.f90 deleted file mode 100644 index a73830caf..000000000 --- a/base/serial/psb_zspsetbld.f90 +++ /dev/null @@ -1,152 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspgtblk.f90 -! Subroutine: psb_zspgtblk -! Gets one or more rows from a sparse matrix. -! Arguments: -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, * -!* * -!***************************************************************************** -subroutine psb_zspsetbld1(a,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zspsetbld1 - - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer, intent(out) :: info - - logical :: append_,srt_ - integer :: i,j, err_act - character(len=20) :: name - - name='psb_sp_setbld' - info = 0 - call psb_erractionsave(err_act) - - select case(psb_sp_getifld(psb_state_,a,info)) - case (psb_spmat_asb_,psb_spmat_upd_) - call psb_spcnv(a,info,afmt='COO') - if (info == 0) call psb_sp_setifld(psb_spmat_bld_,psb_state_,a,info) - case (psb_spmat_bld_) - ! do nothing - - case default - info=591 - call psb_errpush(info,name) - goto 9999 - end select - - - if (info /= 0) then - call psb_errpush(4010,name,a_err='Internal call') - goto 9999 - end if - - call psb_erractionrestore(err_act) - - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_zspsetbld1 -subroutine psb_zspsetbld2(a,b,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zspsetbld2 - - implicit none - - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(out) :: b - integer, intent(out) :: info - - logical :: append_,srt_ - integer :: i,j, err_act - character(len=20) :: name - - name='psb_sp_setbld' - info = 0 - call psb_erractionsave(err_act) - - - select case(psb_sp_getifld(psb_state_,a,info)) - case (psb_spmat_asb_,psb_spmat_upd_) - call psb_spcnv(a,b,info,afmt='COO') - if (info == 0) call psb_sp_setifld(psb_spmat_bld_,psb_state_,b,info) - - case (psb_spmat_bld_) - call psb_sp_clone(a,b,info) - - case default - info=591 - call psb_errpush(info,name) - goto 9999 - end select - - if (info /= 0) then - call psb_errpush(4010,name,a_err='Internal call') - goto 9999 - end if - - call psb_erractionrestore(err_act) - - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_zspsetbld2 - diff --git a/base/serial/psb_zspshift.f90 b/base/serial/psb_zspshift.f90 deleted file mode 100644 index 71d44a728..000000000 --- a/base/serial/psb_zspshift.f90 +++ /dev/null @@ -1,91 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_zspgtblk.f90 -! Subroutine: psb_zspgtblk -! Gets one or more rows from a sparse matrix. -! Arguments: -!***************************************************************************** -!* * -!* Takes a specified row from matrix A and copies into matrix B (possibly * -!* appending to B). Output is always COO. Input might be anything, * -!* * -!***************************************************************************** -subroutine psb_zspshift(alpha,a,beta,b,info) - ! Output is always in COO format into B, irrespective of - ! the input format - use psb_spmat_type - use psb_const_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_zspshift - - implicit none - - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(out) :: b - complex(psb_dpk_), intent(in) :: alpha, beta - integer, intent(out) :: info - - logical :: append_,srt_ - integer :: i,j, err_act - character(len=20) :: name - - name='psb_sp_shift' - info = 0 - call psb_erractionsave(err_act) - - call psb_sp_setbld(a,b,info) - if (info == 0) call psb_sp_scal(b,alpha,info) - do i=1,min(b%m,b%k) - if (info == 0) call psb_coins(1,(/i/),(/i/),(/beta/),b,1,1,b%m,b%k,info) - end do - if (info == 0) call psb_spcnv(b,info,afmt=a%fida,dupl=psb_dupl_add_) - - if (info /= 0) then - call psb_errpush(4010,name,a_err='Internal call') - goto 9999 - end if - - call psb_erractionrestore(err_act) - - return - -9999 continue - call psb_erractionrestore(err_act) - if (err_act == psb_act_abort_) then - call psb_error() - return - end if - return - - -end subroutine psb_zspshift - diff --git a/base/serial/psb_ztransc.f90 b/base/serial/psb_ztransc.f90 deleted file mode 100644 index a02647a9f..000000000 --- a/base/serial/psb_ztransc.f90 +++ /dev/null @@ -1,84 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ztransc.f90 -! Subroutine: -! Arguments: - -subroutine psb_ztransc(a,b,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_ztransc - implicit none - - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(out) :: b - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer :: c_, info, i - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_nullify_sp(b) - - call psb_spcnv(a,b,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(b%ia1,itmp,info) - call psb_move_alloc(b%ia2,b%ia1,info) - call psb_move_alloc(itmp,b%ia2,info) - - do i=1, b%infoa(psb_nnz_) - b%aspk(i) = conjg(b%aspk(i)) - end do - - b%m = a%k - b%k = a%m - call psb_spcnv(b,info,afmt=fmt_) - - return -end subroutine psb_ztransc diff --git a/base/serial/psb_ztransp.f90 b/base/serial/psb_ztransp.f90 deleted file mode 100644 index af9f0cce1..000000000 --- a/base/serial/psb_ztransp.f90 +++ /dev/null @@ -1,121 +0,0 @@ -!!$ -!!$ Parallel Sparse BLAS version 2.2 -!!$ (C) Copyright 2006/2007/2008 -!!$ Salvatore Filippone University of Rome Tor Vergata -!!$ Alfredo Buttari University of Rome Tor Vergata -!!$ -!!$ Redistribution and use in source and binary forms, with or without -!!$ modification, are permitted provided that the following conditions -!!$ are met: -!!$ 1. Redistributions of source code must retain the above copyright -!!$ notice, this list of conditions and the following disclaimer. -!!$ 2. Redistributions in binary form must reproduce the above copyright -!!$ notice, this list of conditions, and the following disclaimer in the -!!$ documentation and/or other materials provided with the distribution. -!!$ 3. The name of the PSBLAS group or the names of its contributors may -!!$ not be used to endorse or promote products derived from this -!!$ software without specific written permission. -!!$ -!!$ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -!!$ ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -!!$ TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -!!$ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE PSBLAS GROUP OR ITS CONTRIBUTORS -!!$ BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -!!$ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -!!$ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS -!!$ INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN -!!$ CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) -!!$ ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE -!!$ POSSIBILITY OF SUCH DAMAGE. -!!$ -!!$ -! File: psb_ztransp.f90 -! Subroutine: -! Arguments: - -subroutine psb_ztransp(a,b,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_ztransp - implicit none - - type(psb_zspmat_type), intent(in) :: a - type(psb_zspmat_type), intent(out) :: b - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer :: c_, info - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_nullify_sp(b) - - call psb_spcnv(a,b,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(b%ia1,itmp,info) - call psb_move_alloc(b%ia2,b%ia1,info) - call psb_move_alloc(itmp,b%ia2,info) - - b%m = a%k - b%k = a%m - call psb_spcnv(b,info,afmt=fmt_) - - return -end subroutine psb_ztransp - -subroutine psb_ztransp1(a,c,fmt) - use psb_spmat_type - use psb_tools_mod - use psb_string_mod - use psb_serial_mod, psb_protect_name => psb_ztransp1 - implicit none - - type(psb_zspmat_type), intent(inout) :: a - integer, optional :: c - character(len=*), optional :: fmt - - character(len=5) :: fmt_ - integer ::c_, info - integer, allocatable :: itmp(:) - - if (present(c)) then - c_=c - else - c_=1 - endif - if (present(fmt)) then - fmt_ = psb_toupper(fmt) - else - fmt_='CSR' - endif - - call psb_spcnv(a,info,afmt='coo') - - if (info /= 0) then - write(0,*) 'transp: info from CSDP ',info - return - end if - call psb_move_alloc(a%ia1,itmp,info) - call psb_move_alloc(a%ia2,a%ia1,info) - call psb_move_alloc(itmp,a%ia2,info) - - call psb_spcnv(a,info,afmt=fmt_) - - return -end subroutine psb_ztransp1