C ALGORITHM 784, COLLECTED ALGORITHMS FROM ACM. C THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE, C VOL. 24,NO. 3, September, 1998, P. 303--316. #! /bin/sh # This is a shell archive, meaning: # 1. Remove everything above the #! /bin/sh line. # 2. Save the resulting text in a file. # 3. Execute the file with /bin/sh (not csh) to create the files: # Package/ # Package/GBBEN/ # Package/GBBEN/CBENCH/ # Package/GBBEN/CBENCH/Makefile # Package/GBBEN/CBENCH/cgb02.f # Package/GBBEN/CBENCH/cgb03.f # Package/GBBEN/CBENCH/cgb04.f # Package/GBBEN/CBENCH/cgb05.f # Package/GBBEN/CBENCH/cgb06.f # Package/GBBEN/CBENCH/cgb07.f # Package/GBBEN/CBENCH/cgb08.f # Package/GBBEN/CBENCH/cgb09.f # Package/GBBEN/CBENCH/cgb90.f # Package/GBBEN/CBENCH/cgb91.f # Package/GBBEN/CBENCH/cgbt01.f # Package/GBBEN/CBENCH/cgbt02.f # Package/GBBEN/CBENCH/cgbtim.f # Package/GBBEN/CBENCH/cgbtp1.f # Package/GBBEN/CBENCH/cgbtp2.f # Package/GBBEN/CBENCH/cmark01.in # Package/GBBEN/CBENCH/cmark02.in # Package/GBBEN/CBENCH/csbpm.f # Package/GBBEN/CBENCH/eoln.f # Package/GBBEN/CBENCH/example.in # Package/GBBEN/CBENCH/getwrd.f # Package/GBBEN/CBENCH/lsame.f # Package/GBBEN/CBENCH/newcgpm.in # Package/GBBEN/CBENCH/xerbla.f # Package/GBBEN/DBENCH/ # Package/GBBEN/DBENCH/Makefile # Package/GBBEN/DBENCH/dgb02.f # Package/GBBEN/DBENCH/dgb04.f # Package/GBBEN/DBENCH/dgb06.f # Package/GBBEN/DBENCH/dgb08.f # Package/GBBEN/DBENCH/dgb09.f # Package/GBBEN/DBENCH/dgb90.f # Package/GBBEN/DBENCH/dgb91.f # Package/GBBEN/DBENCH/dgbt01.f # Package/GBBEN/DBENCH/dgbt02.f # Package/GBBEN/DBENCH/dgbtim.f # Package/GBBEN/DBENCH/dgbtp1.f # Package/GBBEN/DBENCH/dgbtp2.f # Package/GBBEN/DBENCH/dmark01.in # Package/GBBEN/DBENCH/dmark02.in # Package/GBBEN/DBENCH/dsbpm.f # Package/GBBEN/DBENCH/eoln.f # Package/GBBEN/DBENCH/example.in # Package/GBBEN/DBENCH/getwrd.f # Package/GBBEN/DBENCH/lsame.f # Package/GBBEN/DBENCH/newdgpm.in # Package/GBBEN/DBENCH/xerbla.f # Package/GBBEN/Makefile # Package/GBBEN/SBENCH/ # Package/GBBEN/SBENCH/Makefile # Package/GBBEN/SBENCH/eoln.f # Package/GBBEN/SBENCH/example.in # Package/GBBEN/SBENCH/getwrd.f # Package/GBBEN/SBENCH/lsame.f # Package/GBBEN/SBENCH/newsgpm.in # Package/GBBEN/SBENCH/sgb02.f # Package/GBBEN/SBENCH/sgb04.f # Package/GBBEN/SBENCH/sgb06.f # Package/GBBEN/SBENCH/sgb08.f # Package/GBBEN/SBENCH/sgb09.f # Package/GBBEN/SBENCH/sgb90.f # Package/GBBEN/SBENCH/sgb91.f # Package/GBBEN/SBENCH/sgbt01.f # Package/GBBEN/SBENCH/sgbt02.f # Package/GBBEN/SBENCH/sgbtim.f # Package/GBBEN/SBENCH/sgbtp1.f # Package/GBBEN/SBENCH/sgbtp2.f # Package/GBBEN/SBENCH/smark01.in # Package/GBBEN/SBENCH/smark02.in # Package/GBBEN/SBENCH/ssbpm.f # Package/GBBEN/SBENCH/xerbla.f # Package/GBBEN/TMGLIB/ # Package/GBBEN/TMGLIB/Makefile # Package/GBBEN/TMGLIB/dsecnd.f # Package/GBBEN/TMGLIB/second.f # Package/GBBEN/ZBENCH/ # Package/GBBEN/ZBENCH/Makefile # Package/GBBEN/ZBENCH/eoln.f # Package/GBBEN/ZBENCH/example.in # Package/GBBEN/ZBENCH/getwrd.f # Package/GBBEN/ZBENCH/lsame.f # Package/GBBEN/ZBENCH/newzgpm.in # Package/GBBEN/ZBENCH/xerbla.f # Package/GBBEN/ZBENCH/zgb02.f # Package/GBBEN/ZBENCH/zgb03.f # Package/GBBEN/ZBENCH/zgb04.f # Package/GBBEN/ZBENCH/zgb05.f # Package/GBBEN/ZBENCH/zgb06.f # Package/GBBEN/ZBENCH/zgb07.f # Package/GBBEN/ZBENCH/zgb08.f # Package/GBBEN/ZBENCH/zgb09.f # Package/GBBEN/ZBENCH/zgb90.f # Package/GBBEN/ZBENCH/zgb91.f # Package/GBBEN/ZBENCH/zgbt01.f # Package/GBBEN/ZBENCH/zgbt02.f # Package/GBBEN/ZBENCH/zgbtim.f # Package/GBBEN/ZBENCH/zgbtp1.f # Package/GBBEN/ZBENCH/zgbtp2.f # Package/GBBEN/ZBENCH/zmark01.in # Package/GBBEN/ZBENCH/zmark02.in # Package/GBBEN/ZBENCH/zsbpm.f # Package/GBBEN/make.gbinc # Package/GBL3B/ # Package/GBL3B/CGBL3B/ # Package/GBL3B/CGBL3B/Makefile # Package/GBL3B/CGBL3B/cbigp.f # Package/GBL3B/CGBL3B/ccld.f # Package/GBL3B/CGBL3B/cgpm.in # Package/GBL3B/CGBL3B/chemm.f # Package/GBL3B/CGBL3B/cher2k.f # Package/GBL3B/CGBL3B/cherk.f # Package/GBL3B/CGBL3B/csgpm.f # Package/GBL3B/CGBL3B/csymm.f # Package/GBL3B/CGBL3B/csyr2k.f # Package/GBL3B/CGBL3B/csyrk.f # Package/GBL3B/CGBL3B/ctrmm.f # Package/GBL3B/CGBL3B/ctrsm.f # Package/GBL3B/CGBL3B/eoln.f # Package/GBL3B/CGBL3B/getwrd.f # Package/GBL3B/CGBL3B/lsame.f # Package/GBL3B/CGBL3B/xerbla.f # Package/GBL3B/DGBL3B/ # Package/GBL3B/DGBL3B/Makefile # Package/GBL3B/DGBL3B/dbigp.f # Package/GBL3B/DGBL3B/dcld.f # Package/GBL3B/DGBL3B/dgpm.in # Package/GBL3B/DGBL3B/dsgpm.f # Package/GBL3B/DGBL3B/dsymm.f # Package/GBL3B/DGBL3B/dsyr2k.f # Package/GBL3B/DGBL3B/dsyrk.f # Package/GBL3B/DGBL3B/dtrmm.f # Package/GBL3B/DGBL3B/dtrsm.f # Package/GBL3B/DGBL3B/eoln.f # Package/GBL3B/DGBL3B/getwrd.f # Package/GBL3B/DGBL3B/lsame.f # Package/GBL3B/DGBL3B/xerbla.f # Package/GBL3B/Makefile # Package/GBL3B/SGBL3B/ # Package/GBL3B/SGBL3B/Makefile # Package/GBL3B/SGBL3B/eoln.f # Package/GBL3B/SGBL3B/getwrd.f # Package/GBL3B/SGBL3B/lsame.f # Package/GBL3B/SGBL3B/sbigp.f # Package/GBL3B/SGBL3B/scld.f # Package/GBL3B/SGBL3B/sgpm.in # Package/GBL3B/SGBL3B/ssgpm.f # Package/GBL3B/SGBL3B/ssymm.f # Package/GBL3B/SGBL3B/ssyr2k.f # Package/GBL3B/SGBL3B/ssyrk.f # Package/GBL3B/SGBL3B/strmm.f # Package/GBL3B/SGBL3B/strsm.f # Package/GBL3B/SGBL3B/xerbla.f # Package/GBL3B/ZGBL3B/ # Package/GBL3B/ZGBL3B/Makefile # Package/GBL3B/ZGBL3B/eoln.f # Package/GBL3B/ZGBL3B/getwrd.f # Package/GBL3B/ZGBL3B/lsame.f # Package/GBL3B/ZGBL3B/xerbla.f # Package/GBL3B/ZGBL3B/zbigp.f # Package/GBL3B/ZGBL3B/zcld.f # Package/GBL3B/ZGBL3B/zgpm.in # Package/GBL3B/ZGBL3B/zhemm.f # Package/GBL3B/ZGBL3B/zher2k.f # Package/GBL3B/ZGBL3B/zherk.f # Package/GBL3B/ZGBL3B/zsgpm.f # Package/GBL3B/ZGBL3B/zsymm.f # Package/GBL3B/ZGBL3B/zsyr2k.f # Package/GBL3B/ZGBL3B/zsyrk.f # Package/GBL3B/ZGBL3B/ztrmm.f # Package/GBL3B/ZGBL3B/ztrsm.f # Package/GBL3B/make.gbinc # Package/INSTALL/ # Package/INSTALL/Makefile # Package/INSTALL/dsecnd.f # Package/INSTALL/dsecndtst.f # Package/INSTALL/lsame.f # Package/INSTALL/lsametst.f # Package/INSTALL/second.f # Package/INSTALL/secondtst.f # Package/Makefile # Package/README # Package/TESTING/ # Package/TESTING/Makefile # Package/TESTING/SRC/ # Package/TESTING/SRC/Makefile # Package/TESTING/SRC/cblat3.f # Package/TESTING/SRC/dblat3.f # Package/TESTING/SRC/sblat3.f # Package/TESTING/SRC/zblat3.f # Package/TESTING/cblat3.in # Package/TESTING/dblat3.in # Package/TESTING/sblat3.in # Package/TESTING/zblat3.in # UNDERLIB/ # UNDERLIB/Makefile # UNDERLIB/caxpy.f # UNDERLIB/ccopy.f # UNDERLIB/cgemm.f # UNDERLIB/cgemv.f # UNDERLIB/cher.f # UNDERLIB/cscal.f # UNDERLIB/ctrmv.f # UNDERLIB/ctrsv.f # UNDERLIB/daxpy.f # UNDERLIB/dcabs1.f # UNDERLIB/dcopy.f # UNDERLIB/dgemm.f # UNDERLIB/dgemv.f # UNDERLIB/dger.f # UNDERLIB/dscal.f # UNDERLIB/dsyr.f # UNDERLIB/dtrmv.f # UNDERLIB/dtrsv.f # UNDERLIB/lsame.f # UNDERLIB/saxpy.f # UNDERLIB/scopy.f # UNDERLIB/sgemm.f # UNDERLIB/sgemv.f # UNDERLIB/sger.f # UNDERLIB/sscal.f # UNDERLIB/ssyr.f # UNDERLIB/strmv.f # UNDERLIB/strsv.f # UNDERLIB/xerbla.f # UNDERLIB/zaxpy.f # UNDERLIB/zcopy.f # UNDERLIB/zgemm.f # UNDERLIB/zgemv.f # UNDERLIB/zher.f # UNDERLIB/zscal.f # UNDERLIB/ztrmv.f # UNDERLIB/ztrsv.f # make.inc # This archive created: Tue Mar 23 08:55:20 1999 export PATH; PATH=/bin:$PATH if test ! -d 'Package' then mkdir 'Package' fi cd 'Package' if test ! -d 'GBBEN' then mkdir 'GBBEN' fi cd 'GBBEN' if test ! -d 'CBENCH' then mkdir 'CBENCH' fi cd 'CBENCH' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### GEMM-Based Level 3 BLAS Benchmark #################################### # # The following libraries are specified, a user specified level 3 BLAS # library to be timed (LIB3B), a library with underlying BLAS routines # (LIB12B) where the underlying BLAS routine CGEMM may be specified # separately, and the library with the timing functions SECOND and # DSECND (CSEC). # LIB3B = $(ULIB) CGEMM = $(UULIB) LIB12B = $(UULIB) CSEC = $(UTMG) # # LIB specifies the order in which the libraries are linked with the # benchmark programs. Notice that the built-in GEMM-based routines # will be linked the first CGEMM, level 1 and 2 BLAS routines found # as underlying routines. Change the order in which the libraries are # linked as desired. # LIB = $(CSEC) $(LIB3B) $(CGEMM) $(LIB12B) # ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # CBMFLG : the GEMM-based performance benchmark programs # CPRFLG : routines that print the output results # CGBFLG : the built-in GEMM-based level 3 BLAS routines # CAXFLG : GEMM-based specific auxiliary routines # AXOPT : other auxiliary routines # CBMFLG = $(GBBOPT) CPRFLG = $(AXOPT) CGBFLG = $(GBOPT) CAXFLG = $(GBOPT) AXFLG = $(AXOPT) # ######################################################################## CTIMS = cgbtim.f CTIM = cgbtim.o CBMS = cgbt01.f cgbt02.f CBM = cgbt01.o cgbt02.o CPRS = cgbtp1.f cgbtp2.f CPR = cgbtp1.o cgbtp2.o CGBS = cgb02.f cgb03.f cgb04.f cgb05.f cgb06.f cgb07.f cgb08.f cgb09.f CGB = cgb02.o cgb03.o cgb04.o cgb05.o cgb06.o cgb07.o cgb08.o cgb09.o CAUXS = cgb90.f cgb91.f CAUX = cgb90.o cgb91.o AUXS = lsame.f xerbla.f AUX = lsame.o xerbla.o CPRMS = csbpm.f CPRM = csbpm.o AUXS2 = getwrd.f eoln.f AUX2 = getwrd.o eoln.o OBJ1 = $(CTIM) $(CBM) $(CGB) $(CAUX) $(AUX) $(AUX2) $(CPR) OBJ2 = $(CPRM) $(AUX2) ######################################################################## all: cgbtim csbpm cgbtim: $(OBJ1) $(LOADER) $(LOADOPT) -o cgbtim $(OBJ1) $(LIB) csbpm: $(OBJ2) $(LOADER) $(LOADOPT) -o csbpm $(OBJ2) $(CTIM): $(CTIMS) $(FORTRAN) -c $(CBMFLG) $(CTIMS) $(CBM): $(CBMS) $(FORTRAN) -c $(CBMFLG) $(CBMS) $(CPR): $(CPRS) $(FORTRAN) -c $(CPRFLG) $(CPRS) $(CGB): $(CGBS) $(FORTRAN) -c $(CGBFLG) $(CGBS) $(CAUX): $(CAUXS) $(FORTRAN) -c $(CAXFLG) $(CAUXS) $(AUX): $(AUXS) $(FORTRAN) -c $(AXFLG) $(AUXS) $(CPRM): $(CPRMS) $(FORTRAN) -c $(AXFLG) $(CPRMS) $(AUX2): $(AUXS2) $(FORTRAN) -c $(AXFLG) $(AUXS2) clean: rm -f *.o cgbtim csbpm SHAR_EOF fi # end of overwriting check if test -f 'cgb02.f' then echo shar: will not over-write existing file "'cgb02.f'" else cat << SHAR_EOF > 'cgb02.f' SUBROUTINE CGB02 ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGB02 (CSYMM) performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is a symmetric matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the symmetric matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the symmetric matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * symmetric matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * symmetric matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - COMPLEX. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CCOPY * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. User specified parameters for CGB02 .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGB02 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL CGEMM ( 'N', 'N', M, N, 0, ZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by CCOPY is CB. * DO 30, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 20, J = JJ+1, II+ISEC-1 CALL CCOPY ( MIN( JSEC, J-JJ ), A( JJ, J ), 1, $ T1( J-II+1, JJ-II+1 ), RCB ) 20 CONTINUE 30 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL CGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 80, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 50, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 50 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by CCOPY is CB. * DO 70, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 60, J = II, JJ+JSEC-2 CALL CCOPY ( MIN( JSEC, JJ+JSEC-1-J ), $ A( MAX( JJ, J+1 ), J ), 1, $ T1( J-II+1, MAX( JJ-II+1, J-II+2 ) ), RCB ) 60 CONTINUE 70 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF 80 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 120, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 90, J = JJ, JJ+JSEC-1 CALL CCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 90 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by CCOPY is CB. * DO 110, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 100, I = II+1, JJ+JSEC-1 CALL CCOPY ( MIN( ISEC, I-II ), A( II, I ), 1, $ T1( I-JJ+1, II-JJ+1 ), RCB ) 100 CONTINUE 110 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF 120 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 160, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL CCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 130 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by CCOPY is CB. * DO 150, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 140, I = JJ, II+ISEC-2 CALL CCOPY ( MIN( ISEC, II+ISEC-1-I ), $ A( MAX( II, I+1 ), I ), 1, $ T1( I-JJ+1, MAX( II-JJ+1, I-JJ+2 ) ), RCB ) 140 CONTINUE 150 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 160 CONTINUE END IF END IF * RETURN * * End of CGB02. * END SHAR_EOF fi # end of overwriting check if test -f 'cgb03.f' then echo shar: will not over-write existing file "'cgb03.f'" else cat << SHAR_EOF > 'cgb03.f' SUBROUTINE CGB03 ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGB03 (CHEMM) performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is an hermitian matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the hermitian matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the hermitian matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * hermitian matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * hermitian matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the hermitian matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the hermitian matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the hermitian * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the hermitian matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the hermitian matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the hermitian * matrix and the strictly upper triangular part of A is not * referenced. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - COMPLEX . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL, CMPLX, CONJG * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CCOPY * .. Parameters .. REAL ZERO COMPLEX CZERO, CONE PARAMETER ( ZERO = 0.0E+0, $ CZERO = ( 0.0E+0, 0.0E+0 ), $ CONE = ( 1.0E+0, 0.0E+0 ) ) * .. User specified parameters for CGB03 .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGB03 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.CZERO ).AND.( BETA.EQ.CONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.CZERO )THEN CALL CGEMM ( 'N', 'N', M, N, 0, CZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 60, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 20, I = 1, ISEC T1( I, I ) = CMPLX( REAL( T1( I, I ) ), ZERO ) 20 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly upper triangular diagonal block of A is copied * to the strictly lower triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 50, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 40, J = JJ+1, II+ISEC-1 DO 30, I = JJ, J-1 T1( J-II+1, I-II+1 ) = CONJG( A( I, J ) ) 30 CONTINUE 40 CONTINUE 50 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*conjg( A' )*B + C and C := alpha*A*B + C, * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL CGEMM ( 'C', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ CONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, CONE, C( II, 1 ), LDC ) END IF 60 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 120, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 70, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 70 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 80, I = 1, ISEC T1( I, I ) = CMPLX( REAL( T1( I, I ) ), ZERO ) 80 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly lower triangular diagonal block of A is copied * to the strictly upper triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 110, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 100, J = II, JJ+JSEC-2 DO 90, I = J+1, II+ISEC-1 T1( J-II+1, I-II+1 ) = CONJG( A( I, J ) ) 90 CONTINUE 100 CONTINUE 110 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*conjg( A' )*B + C and C := alpha*A*B + C, * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'C', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, CONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ CONE, C( II, 1 ), LDC ) END IF 120 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 180, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL CCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 130 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 140, J = 1, JSEC T1( J, J ) = CMPLX( REAL( T1( J, J ) ), ZERO ) 140 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly upper triangular diagonal block of A is copied * to the strictly lower triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 170, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 160, I = II+1, JJ+JSEC-1 DO 150, J = II, I-1 T1( I-JJ+1, J-JJ+1 ) = CONJG( A( J, I ) ) 150 CONTINUE 160 CONTINUE 170 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*conjg( A' ) + C, * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ CONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'C', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, CONE, C( 1, JJ ), LDC ) END IF 180 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 240, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 190, J = JJ, JJ+JSEC-1 CALL CCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 190 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 200, J = 1, JSEC T1( J, J ) = CMPLX( REAL( T1( J, J ) ), ZERO ) 200 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly lower triangular diagonal block of A is copied * to the strictly upper triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 230, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 220, I = JJ, II+ISEC-2 DO 210, J = I+1, JJ+JSEC-1 T1( I-JJ+1, J-JJ+1 ) = CONJG( A( J, I ) ) 210 CONTINUE 220 CONTINUE 230 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*conjg( A' ) + C, * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, CONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'C', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ CONE, C( 1, JJ ), LDC ) END IF 240 CONTINUE END IF END IF * RETURN * * End of CGB03. * END SHAR_EOF fi # end of overwriting check if test -f 'cgb04.f' then echo shar: will not over-write existing file "'cgb04.f'" else cat << SHAR_EOF > 'cgb04.f' SUBROUTINE CGB04 ( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGB04 (CSYRK) performs one of the symmetric rank k operations * * C := alpha*A*A' + beta*C, * * or * * C := alpha*A'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A is an n by k matrix in the first case and a k by n matrix * in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. * * TRANS = 'T' or 't' C := alpha*A'*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'T' or 't', K specifies the number of rows of the * matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - COMPLEX . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK COMPLEX DELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME, CGB90, CGB91 EXTERNAL LSAME, CGB90, CGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CGEMV, CCOPY, CSCAL * .. Parameters .. COMPLEX ONE, ZERO INTEGER CIP41, CIP42 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ), $ CIP41 = 41, CIP42 = 42 ) * .. User specified parameters for CGB04 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( ( .NOT.NOTR ) ).AND.( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGB04 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL CSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL CSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Upper, Notr. * SMALLN = .NOT.CGB90( CIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CGB90( CIP42 , N, K ) DO 110, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 50, I = II, II+ISEC-1 DO 40, L = 1, K CALL CAXPY ( I-II+1, ALPHA*A( I, L ), $ A( II, L ), 1, C( II, I ), 1 ) 40 CONTINUE 50 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 60, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 60 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 70, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having upper * triangular storage format. * DO 90, I = II, II+ISEC-1 DO 80, L = 1, K CALL CAXPY ( I-II+1, ALPHA*A( I, L ), $ A( II, L ), 1, T2( 1, I-II+1 ), 1 ) 80 CONTINUE 90 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 100, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 100 CONTINUE END IF 110 CONTINUE ELSE DO 150, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 140, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 120, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 120 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 130, I = II, II+ISEC-1 CALL CGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 130 CONTINUE DELTA = ONE 140 CONTINUE 150 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Upper, Trans. * SMALLN = .NOT.CGB90( CIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CGB90( CIP42 , N, K ) DO 260, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 160, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, C( II, I ), 1 ) 160 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 180, I = II, II+ISEC-1 DO 170, L = 1, K CALL CAXPY ( I-II+1, ALPHA*A( L, I ), $ A( L, II ), LDA, C( II, I ), 1 ) 170 CONTINUE 180 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 190, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 190 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 200, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 200 CONTINUE END IF DO 240, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 210, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 210 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * upper triangular storage format. * DO 230, I = II, II+ISEC-1 DO 220, L = LL, LL+LSEC-1 CALL CAXPY ( I-II+1, $ ALPHA*T3( I-II+1, L-LL+1 ), $ T3( 1, L-LL+1 ), 1, $ T2( 1, I-II+1 ), 1 ) 220 CONTINUE 230 CONTINUE 240 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 250, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 250 CONTINUE END IF 260 CONTINUE ELSE CLDA = CGB91( LDA ) DO 310, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 300, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 270, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 280 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 290, I = II, II+ISEC-1 CALL CGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 290 CONTINUE DELTA = ONE 300 CONTINUE 310 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Lower, Notr. * SMALLN = .NOT.CGB90( CIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CGB90( CIP42 , N, K ) DO 400, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 320, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 320 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 340, I = II, II+ISEC-1 DO 330, L = 1, K CALL CAXPY ( II+ISEC-I, ALPHA*A( I, L ), $ A( I, L ), 1, C( I, I ), 1 ) 330 CONTINUE 340 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 350, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 350 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 360, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 360 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having lower * triangular storage format. * DO 380, I = II, II+ISEC-1 DO 370, L = 1, K CALL CAXPY ( II+ISEC-I, ALPHA*A( I, L ), $ A( I, L ), 1, T2( I-II+1, I-II+1 ), 1 ) 370 CONTINUE 380 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 390, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 400 CONTINUE ELSE DO 440, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 430, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 410, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 410 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 420, I = II, II+ISEC-1 CALL CGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 420 CONTINUE DELTA = ONE 430 CONTINUE * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 440 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Lower, Trans. * SMALLN = .NOT.CGB90( CIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CGB90( CIP42 , N, K ) DO 550, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 450, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 450 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 470, I = II, II+ISEC-1 DO 460, L = 1, K CALL CAXPY ( II+ISEC-I, ALPHA*A( L, I ), $ A( L, I ), LDA, C( I, I ), 1 ) 460 CONTINUE 470 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 480, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 480 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 490, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 490 CONTINUE END IF DO 530, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 500, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 500 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * lower triangular storage format. * DO 520, I = II, II+ISEC-1 DO 510, L = LL, LL+LSEC-1 CALL CAXPY ( II+ISEC-I, $ ALPHA*T3( I-II+1, L-LL+1 ), $ T3( I-II+1, L-LL+1 ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 510 CONTINUE 520 CONTINUE 530 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 540, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 540 CONTINUE END IF * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 550 CONTINUE ELSE CLDA = CGB91( LDA ) DO 600, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 590, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 560, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 560 CONTINUE ELSE DO 570, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 570 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 580, I = II, II+ISEC-1 CALL CGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 580 CONTINUE DELTA = ONE 590 CONTINUE * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 600 CONTINUE END IF END IF END IF * RETURN * * End of CGB04. * END SHAR_EOF fi # end of overwriting check if test -f 'cgb05.f' then echo shar: will not over-write existing file "'cgb05.f'" else cat << SHAR_EOF > 'cgb05.f' SUBROUTINE CGB05 ( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC REAL ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGB05 (CHERK) performs one of the hermitian rank k operations * * C := alpha*A*conjg( A' ) + beta*C, * * or * * C := alpha*conjg( A' )*A + beta*C, * * where alpha and beta are real scalars, C is an n by n hermitian * matrix and A is an n by k matrix in the first case and a k by n * matrix in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. * * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'C' or 'c', K specifies the number of rows of the * matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK COMPLEX CALPHA, CBETA, CDELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX, REAL, CMPLX, CONJG * .. External Functions .. LOGICAL LSAME, CGB90, CGB91 EXTERNAL LSAME, CGB90, CGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CGEMV, CHER, CCOPY, CSCAL * .. Parameters .. REAL ONE, ZERO COMPLEX CONE INTEGER CIP51, CIP52 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, $ CONE = ( 1.0E+0, 0.0E+0 ), $ CIP51 = 51, CIP52 = 52 ) * .. User specified parameters for CGB05 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ), $ T4( CB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGB05 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * CALPHA = CMPLX( ALPHA, ZERO ) CBETA = CMPLX( BETA, ZERO ) * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN C( 1, 1 ) = CMPLX( BETA*REAL( C( 1, 1 ) ), ZERO ) DO 10, I = 2, N CALL CSCAL ( I-1, CBETA, C( 1, I ), 1 ) C( I, I ) = CMPLX( BETA*REAL( C( I, I ) ), ZERO ) 10 CONTINUE ELSE DO 20, I = 1, N-1 C( I, I ) = CMPLX( BETA*REAL( C( I, I ) ), ZERO ) CALL CSCAL ( N-I, CBETA, C( I+1, I ), 1 ) 20 CONTINUE C( N, N ) = CMPLX( BETA*REAL( C( N, N ) ), ZERO ) END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*conjg( A' ) + beta*C. Upper, Notr. * SMALLN = .NOT.CGB90( CIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CGB90( CIP52 , N, K ) DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'C', II-1, ISEC, K, CALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ CBETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN C( II, II ) = $ CMPLX( BETA*REAL( C( II, II ) ), ZERO ) DO 30, I = II+1, II+ISEC-1 CALL CSCAL ( I-II, CBETA, C( II, I ), 1 ) C( I, I ) = $ CMPLX( BETA*REAL( C( I, I ) ), ZERO ) 30 CONTINUE END IF * * C := alpha*A*conjg( A' ) + C, hermitian matrix * multiply. C is a hermitian diagonal block having * upper triangular storage format. * DO 40, L = 1, K CALL CHER ( 'U', ISEC, ALPHA, A( II, L ), $ 1, C( II, II ), LDC ) 40 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * hermitian matrix C is copied to the upper * triangular part of T2. * DO 50, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 50 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. The imaginary part of the * diagonal elements of T2 are set to ZERO. * IF( BETA.NE.ONE )THEN T2( 1, 1 ) = $ CMPLX( BETA*REAL( T2( 1, 1 ) ), ZERO ) DO 60, I = 2, ISEC CALL CSCAL ( I-1, CBETA, T2( 1, I ), 1 ) T2( I, I ) = $ CMPLX( BETA*REAL( T2( I, I ) ), ZERO ) 60 CONTINUE END IF * * T2 := alpha*A*conjg( A' ) + T2, hermitian matrix * multiply. T2 contains a hermitian block having * upper triangular storage format. * DO 70, L = 1, K CALL CHER ( 'U', ISEC, ALPHA, A( II, L ), $ 1, T2( 1, 1 ), RCB ) 70 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 80, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 80 CONTINUE END IF 90 CONTINUE ELSE DO 140, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'C', II-1, ISEC, K, CALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ CBETA, C( 1, II ), LDC ) END IF CDELTA = CBETA DO 130, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 100, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 100 CONTINUE * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 120, I = II, II+ISEC-1 DO 110, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ CONJG( T1( I-II+1, L-LL+1 ) ) 110 CONTINUE CALL CGEMV ( 'N', I-II+1, LSEC, CALPHA, $ T1( 1, 1 ), RB, T4( 1 ), 1, $ CDELTA, C( II, I ), 1 ) C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 120 CONTINUE CDELTA = CONE 130 CONTINUE 140 CONTINUE END IF ELSE * * Form C := alpha*conjg( A' )*A + beta*C. Upper, Trans. * SMALLN = .NOT.CGB90( CIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CGB90( CIP52 , N, K ) DO 250, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'C', 'N', II-1, ISEC, K, CALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ CBETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN C( II, II ) = $ CMPLX( BETA*REAL( C( II, II ) ), ZERO ) DO 150, I = II+1, II+ISEC-1 CALL CSCAL ( I-II, CBETA, C( II, I ), 1 ) C( I, I ) = $ CMPLX( BETA*REAL( C( I, I ) ), ZERO ) 150 CONTINUE END IF * * C := alpha*conjg( A' )*A + C, hermitian matrix * multiply. C is a hermitian diagonal block having * upper triangular storage format. The local array * T3 is used for temporary storage of the conjugate * transposed vectors of A. * DO 170, L = 1, K DO 160, I = II, II+ISEC-1 T3( I-II+1, 1 ) = CONJG( A( L, I ) ) 160 CONTINUE CALL CHER ( 'U', ISEC, ALPHA, T3( 1, 1 ), $ 1, C( II, II ), LDC ) 170 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * hermitian matrix C is copied to the upper * triangular part of T2. * DO 180, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 180 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 190, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, CBETA, $ T2( 1, I-II+1 ), 1 ) 190 CONTINUE END IF DO 230, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 200, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 200 CONTINUE * * T2 := alpha*conjg( T3' )*T3 + T2, hermitian * matrix multiply. T2 contains a hermitian block * having upper triangular storage format. The * local array T3 is used for temporary storage of * the conjugate transposed vectors of A. * DO 220, L = LL, LL+LSEC-1 DO 210, I = 1, ISEC T3( I, L-LL+1 ) = $ CONJG( T3( I, L-LL+1 ) ) 210 CONTINUE CALL CHER ( 'U', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 220 CONTINUE 230 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 240, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 240 CONTINUE END IF 250 CONTINUE ELSE CLDA = CGB91( LDA ) DO 330, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'C', 'N', II-1, ISEC, K, CALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ CBETA, C( 1, II ), LDC ) END IF CDELTA = CBETA DO 320, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := conjg( A' ), the conjugated transpose of a * rectangular block of A is copied to T1. * IF( CLDA )THEN DO 270, I = II, II+ISEC-1 DO 260, L = LL, LL+LSEC-1 T1( I-II+1, L-LL+1 ) = $ CONJG( A( L, I ) ) 260 CONTINUE 270 CONTINUE ELSE DO 290, L = LL, LL+LSEC-1 DO 280, I = II, II+ISEC-1 T1( I-II+1, L-LL+1 ) = $ CONJG( A( L, I ) ) 280 CONTINUE 290 CONTINUE END IF * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 310, I = II, II+ISEC-1 DO 300, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ CONJG( T1( I-II+1, L-LL+1 ) ) 300 CONTINUE CALL CGEMV ( 'N', I-II+1, LSEC, CALPHA, $ T1( 1, 1 ), RB, T4( 1 ), 1, $ CDELTA, C( II, I ), 1 ) C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 310 CONTINUE CDELTA = CONE 320 CONTINUE 330 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*conjg( A' ) + beta*C. Lower, Notr. * SMALLN = .NOT.CGB90( CIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CGB90( CIP52 , N, K ) DO 400, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 340, I = II, II+ISEC-2 C( I, I ) = $ CMPLX( BETA*REAL( C( I, I ) ), ZERO ) CALL CSCAL ( II+ISEC-I-1, CBETA, $ C( I+1, I ), 1 ) 340 CONTINUE C( II+ISEC-1, II+ISEC-1 ) = $ CMPLX( BETA*REAL( C( II+ISEC-1, $ II+ISEC-1 ) ), ZERO ) END IF * * C := alpha*A*conjg( A' ) + C, hermitian matrix * multiply. C is a hermitian diagonal block having * lower triangular storage format. * DO 350, L = 1, K CALL CHER ( 'L', ISEC, ALPHA, A( II, L ), $ 1, C( II, II ), LDC ) 350 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * hermitian matrix C is copied to the lower * triangular part of T2. * DO 360, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 360 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. The imaginary part of the * diagonal elements of T2 are set to ZERO. * IF( BETA.NE.ONE )THEN DO 370, I = 1, ISEC-1 T2( I, I ) = $ CMPLX( BETA*REAL( T2( I, I ) ), ZERO ) CALL CSCAL ( ISEC-I, CBETA, $ T2( I+1, I ), 1 ) 370 CONTINUE T2( ISEC, ISEC ) = $ CMPLX( BETA*REAL( T2( ISEC, ISEC ) ), $ ZERO ) END IF * * T2 := alpha*A*conjg( A' ) + T2, symmetric matrix * multiply. T2 contains a hermitian block having * lower triangular storage format. * DO 380, L = 1, K CALL CHER ( 'L', ISEC, ALPHA, A( II, L ), $ 1, T2( 1, 1 ), RCB ) 380 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 390, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ CALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, CBETA, C( II+ISEC, II ), LDC ) END IF 400 CONTINUE ELSE DO 450, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 CDELTA = CBETA DO 440, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 410, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 410 CONTINUE * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 430, I = II, II+ISEC-1 DO 420, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ CONJG( T1( I-II+1, L-LL+1 ) ) 420 CONTINUE CALL CGEMV ( 'N', II+ISEC-I, LSEC, CALPHA, $ T1( I-II+1, 1 ), RB, T4( 1 ), 1, $ CDELTA, C( I, I ), 1 ) C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 430 CONTINUE CDELTA = CONE 440 CONTINUE * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ CALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, CBETA, C( II+ISEC, II ), LDC ) END IF 450 CONTINUE END IF ELSE * * Form C := alpha*conjg( A' )*A + beta*C. Lower, Trans. * SMALLN = .NOT.CGB90( CIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CGB90( CIP52 , N, K ) DO 560, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN DO 460, I = II, II+ISEC-2 C( I, I ) = $ CMPLX( BETA*REAL( C( I, I ) ), ZERO ) CALL CSCAL ( II+ISEC-I-1, CBETA, $ C( I+1, I ), 1 ) 460 CONTINUE C( II+ISEC-1, II+ISEC-1 ) = $ CMPLX( BETA*REAL( C( II+ISEC-1, $ II+ISEC-1 ) ), ZERO ) END IF * * C := alpha*conjg( A' )*A + C, hermitian matrix * multiply. C is a hermitian diagonal block having * lower triangular storage format. The local array * T3 is used for temporary storage of the conjugate * transposed vectors of A. * DO 480, L = 1, K DO 470, I = II, II+ISEC-1 T3( I-II+1, 1 ) = CONJG( A( L, I ) ) 470 CONTINUE CALL CHER ( 'L', ISEC, ALPHA, T3( 1, 1 ), $ 1, C( II, II ), LDC ) 480 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 490, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 490 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 500, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, CBETA, $ T2( I-II+1, I-II+1 ), 1 ) 500 CONTINUE END IF DO 540, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 510, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 510 CONTINUE * * T2 := alpha*conjg( T3' )*T3 + T2, hermitian * matrix multiply. T2 contains a hermitian block * having lower triangular storage format. The * local array T3 is used for temporary storage of * the conjugate transposed vectors of A. * DO 530, L = LL, LL+LSEC-1 DO 520, I = 1, ISEC T3( I, L-LL+1 ) = $ CONJG( T3( I, L-LL+1 ) ) 520 CONTINUE CALL CHER ( 'L', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 530 CONTINUE 540 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 550, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 550 CONTINUE END IF * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ CALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, CBETA, C( II+ISEC, II ), LDC ) END IF 560 CONTINUE ELSE CLDA = CGB91( LDA ) DO 650, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 CDELTA = CBETA DO 640, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := conjg( A' ), the conjugated transpose of a * rectangular block of A is copied to T1. * IF( CLDA )THEN DO 580, I = II, II+ISEC-1 DO 570, L = LL, LL+LSEC-1 T1( I-II+1, L-LL+1 ) = $ CONJG( A( L, I ) ) 570 CONTINUE 580 CONTINUE ELSE DO 600, L = LL, LL+LSEC-1 DO 590, I = II, II+ISEC-1 T1( I-II+1, L-LL+1 ) = $ CONJG( A( L, I ) ) 590 CONTINUE 600 CONTINUE END IF * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 630, I = II, II+ISEC-1 DO 620, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ CONJG( T1( I-II+1, L-LL+1 ) ) 620 CONTINUE CALL CGEMV ( 'N', II+ISEC-I, LSEC, CALPHA, $ T1( I-II+1, 1 ), RB, T4( 1 ), 1, $ CDELTA, C( I, I ), 1 ) C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 630 CONTINUE CDELTA = CONE 640 CONTINUE * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ CALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, CBETA, C( II+ISEC, II ), LDC ) END IF 650 CONTINUE END IF END IF END IF * RETURN * * End of CGB05. * END SHAR_EOF fi # end of overwriting check if test -f 'cgb06.f' then echo shar: will not over-write existing file "'cgb06.f'" else cat << SHAR_EOF > 'cgb06.f' SUBROUTINE CGB06 ( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGB06 (CSYR2K) performs one of the symmetric rank 2k operations * * C := alpha*A*B' + alpha*B*A' + beta*C, * * or * * C := alpha*A'*B + alpha*B'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A and B are n by k matrices in the first case and k by n * matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + * beta*C. * * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'T' or 't', K specifies the number of rows of the * matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - COMPLEX . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, JJ, JX, JSEC LOGICAL UPPER, NOTR * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CAXPY, CSCAL * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. User specified parameters for CGB06 .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND. ( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGB06 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL CSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL CSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Upper, Notr. * DO 70, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL CGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL CAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by CAXPY is CB. * DO 60, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 50, I = JJ, II+ISEC-1 CALL CAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 50 CONTINUE 60 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, BETA, $ C( 1, II ), LDC ) CALL CGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ONE, $ C( 1, II ), LDC ) END IF 70 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Upper, Trans. * DO 120, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A'*B, general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL CGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 80, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, C( II, I ), 1 ) 80 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 90, I = II, II+ISEC-1 CALL CAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 90 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by CAXPY is CB. * DO 110, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 100, I = JJ, II+ISEC-1 CALL CAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 100 CONTINUE 110 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, BETA, $ C( 1, II ), LDC ) CALL CGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( 1, II ), LDA, ONE, $ C( 1, II ), LDC ) END IF 120 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Lower, Notr. * DO 170, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL CGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 130, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 130 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 140, I = II, II+ISEC-1 CALL CAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 140 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by CAXPY is CB. * DO 160, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 150, I = II, JJ+JSEC-1 CALL CAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 150 CONTINUE 160 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL CGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ B( II+ISEC, 1 ), LDB, A( II, 1 ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 170 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Lower, Trans. * DO 220, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL CGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 180, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 180 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 190, I = II, II+ISEC-1 CALL CAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 190 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by CAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 CALL CAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 200 CONTINUE 210 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL CGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ B( 1, II+ISEC ), LDB, A( 1, II ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 220 CONTINUE END IF END IF * RETURN * * End of CGB06. * END SHAR_EOF fi # end of overwriting check if test -f 'cgb07.f' then echo shar: will not over-write existing file "'cgb07.f'" else cat << SHAR_EOF > 'cgb07.f' SUBROUTINE CGB07 ( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC REAL BETA COMPLEX ALPHA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGB07 (CHER2K) performs one of the hermitian rank 2k operations * * C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, * * or * * C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, * * where alpha and beta are scalars with beta real, C is an n by n * hermitian matrix and A and B are n by k matrices in the first case * and k by n matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + * conjg( alpha )*B*conjg( A' ) + * beta*C. * * TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + * conjg( alpha )*conjg( B' )*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'C' or 'c', K specifies the number of rows of the * matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC LOGICAL UPPER, NOTR COMPLEX CBETA * .. Intrinsic Functions .. INTRINSIC MIN, MAX, REAL, CMPLX, CONJG * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CAXPY, CSCAL * .. Parameters .. REAL ONE, ZERO COMPLEX CONE, CZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, $ CONE = ( 1.0E+0, 0.0E+0 ), $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. User specified parameters for CGB07 .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGB07 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.CZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * CBETA = CMPLX( BETA, ZERO ) * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.CZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN C( 1, 1 ) = CMPLX( BETA*REAL( C( 1, 1 ) ), ZERO ) DO 10, I = 2, N CALL CSCAL ( I-1, CBETA, C( 1, I ), 1 ) C( I, I ) = CMPLX( BETA*REAL( C( I, I ) ), ZERO ) 10 CONTINUE ELSE DO 20, I = 1, N-1 C( I, I ) = CMPLX( BETA*REAL( C( I, I ) ), ZERO ) CALL CSCAL ( N-I, CBETA, C( I+1, I ), 1 ) 20 CONTINUE C( N, N ) = CMPLX( BETA*REAL( C( N, N ) ), ZERO ) END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*conjg( B' ) + * conjg( alpha )*B*conjg( A' ) + beta*C. Upper, Notr. * DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL CGEMM ( 'N', 'C', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, CZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, CBETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL CAXPY ( I-II+1, CONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * lower triangular part of T1 is added to the upper * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by CAXPY is CB. * DO 70, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 60, I = JJ, II+ISEC-1 DO 50, J = JJ, MIN( JJ+JSEC-1, I ) C( J, I ) = C( J, I ) + $ CONJG( T1( I-II+1, J-II+1 ) ) 50 CONTINUE 60 CONTINUE 70 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 80, I = II, II+ISEC-1 C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 80 CONTINUE * * C := alpha*A*conjg( B' ) + beta*C and * C := conjg( alpha )*B*conjg( A' ) + C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'C', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, CBETA, $ C( 1, II ), LDC ) CALL CGEMM ( 'N', 'C', II-1, ISEC, K, CONJG( ALPHA ), $ B( 1, 1 ), LDB, A( II, 1 ), LDA, CONE, $ C( 1, II ), LDC ) END IF 90 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B + * conjg( alpha )*conjg( B' )*A + beta*C. Upper, Trans. * DO 160, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*conjg( A' )*B, matrix multiply on * rectangular blocks of A and B. T1 is a square block. * CALL CGEMM ( 'C', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, CZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 100, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, CBETA, C( II, I ), 1 ) 100 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 110, I = II, II+ISEC-1 CALL CAXPY ( I-II+1, CONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 110 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * lower triangular part of T1 is added to the upper * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by CAXPY is CB. * DO 140, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 130, I = JJ, II+ISEC-1 DO 120, J = JJ, MIN( JJ+JSEC-1, I ) C( J, I ) = C( J, I ) + $ CONJG( T1( I-II+1, J-II+1 ) ) 120 CONTINUE 130 CONTINUE 140 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 150, I = II, II+ISEC-1 C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 150 CONTINUE * * C := alpha*conjg( A' )*B + beta*C and * C := alpha*conjg( B' )*A + C, matrix multiply on upper * vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'C', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, CBETA, $ C( 1, II ), LDC ) CALL CGEMM ( 'C', 'N', II-1, ISEC, K, CONJG( ALPHA ), $ B( 1, 1 ), LDB, A( 1, II ), LDA, CONE, $ C( 1, II ), LDC ) END IF 160 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*conjg( B' ) + * alpha*B*conjg( A' ) + beta*C. Lower, Notr. * DO 230, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL CGEMM ( 'N', 'C', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, CZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 170, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, CBETA, C( I, I ), 1 ) 170 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 180, I = II, II+ISEC-1 CALL CAXPY ( II+ISEC-I, CONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 180 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * upper triangular part of T1 is added to the lower * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by CAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 DO 190, J = MAX( JJ, I), JJ+JSEC-1 C( J, I ) = C( J, I ) + $ CONJG( T1( I-II+1, J-II+1 ) ) 190 CONTINUE 200 CONTINUE 210 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 220, I = II, II+ISEC-1 C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 220 CONTINUE * * C := alpha*A*conjg( B' ) + beta*C and * C := alpha*B*conjg( A' ) + C, matrix multiply on lower * vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ CBETA, C( II+ISEC, II ), LDC ) CALL CGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ CONJG( ALPHA ), B( II+ISEC, 1 ), LDB, A( II, 1 ), $ LDA, CONE, C( II+ISEC, II ), LDC ) END IF 230 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B + * alpha*conjg( B' )*A + beta*C. Lower, Trans. * DO 300, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL CGEMM ( 'C', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, CZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 240, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, CBETA, C( I, I ), 1 ) 240 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 250, I = II, II+ISEC-1 CALL CAXPY ( II+ISEC-I, CONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 250 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * upper triangular part of T1 is added to the lower * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by CAXPY is CB. * DO 280, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 270, I = II, JJ+JSEC-1 DO 260, J = MAX( JJ, I), JJ+JSEC-1 C( J, I ) = C( J, I ) + $ CONJG( T1( I-II+1, J-II+1 ) ) 260 CONTINUE 270 CONTINUE 280 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 290, I = II, II+ISEC-1 C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 290 CONTINUE * * C := alpha*conjg( A' )*B + beta*C and * C := alpha*conjg( B' )*A + C, matrix multiply on lower * vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ CBETA, C( II+ISEC, II ), LDC ) CALL CGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ CONJG( ALPHA ), B( 1, II+ISEC ), LDB, A( 1, II ), $ LDA, CONE, C( II+ISEC, II ), LDC ) END IF 300 CONTINUE END IF END IF * RETURN * * End of CGB07 . * END SHAR_EOF fi # end of overwriting check if test -f 'cgb08.f' then echo shar: will not over-write existing file "'cgb08.f'" else cat << SHAR_EOF > 'cgb08.f' SUBROUTINE CGB08 ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC COMPLEX ALPHA * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGB08 (CTRMM) performs one of the matrix-matrix operations * * C := alpha*op( A )*C, or C := alpha*C*op( A ) * * where alpha is a scalar, C is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies C from * the left or right as follows: * * SIDE = 'L' or 'l' C := alpha*op( A )*C. * * SIDE = 'R' or 'r' C := alpha*C*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, and on exit is overwritten by the * transformed matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOCONJ, NOUNIT, $ CLDC, SMALLN, TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC COMPLEX GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD, CONJG * .. External Functions .. LOGICAL LSAME, CGB90, CGB91 EXTERNAL LSAME, CGB90, CGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CGEMV, CTRMV, CCOPY * .. Parameters .. COMPLEX ZERO, ONE INTEGER CIP81, CIP82, CIP83 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ), $ CIP81 = 81, CIP82 = 82, CIP83 = 83 ) * .. User specified parameters for CGB08 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) COMPLEX T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( ( .NOT.NOTR ).AND.( .NOT.NOCONJ ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGB08 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL CGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*C. Left, Upper, No transpose. * SMALLN = .NOT.CGB90( CIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.CGB90( CIP82, M, N ) DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 10, J = 1, N CALL CTRMV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * C := T3*C, triangular matrix multiply involving * a upper triangular diagonal block of A stored * in T3. * DO 30, J = 1, N CALL CTRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE DELTA = ALPHA CLDC = CGB91( LDC ) DO 110, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in CGEMV that appears if the second * dimension (tsec) is zero. * DO 80, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 110 CONTINUE END IF ELSE * * Form C := alpha*A'*C or C := alpha*conjg( A' )*C. * Left, Upper, Transpose or Conjugated transpose * SMALLN = .NOT.CGB90( CIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.CGB90( CIP82, M, N ) DO 150, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( TRANSA, 'N', ISEC, N, 0, ZERO, A, $ LDA, C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C or C := conjg( A' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A. * DO 120, J = 1, N CALL CTRMV ( 'U', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 130 CONTINUE * * C := T3'*C or C := conjg( T3' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A stored in T3. * DO 140, J = 1, N CALL CTRMV ( 'U', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL CGEMM ( TRANSA, 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 150 CONTINUE ELSE DELTA = ALPHA CLDC = CGB91( LDC ) DO 240, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * upper triangular diagonal block of A is copied to * the upper triangular part of T2. * IF( NOCONJ )THEN DO 160, J = II+OFFD, II+ISEC-1 CALL CCOPY ( J-II+1-OFFD, A( II, J ), 1, $ T2( 1, J-II+1 ), 1 ) 160 CONTINUE ELSE DO 180, J = II+OFFD, II+ISEC-1 DO 170, I = II, J-OFFD T2( I-II+1, J-II+1 ) = CONJG( A( I, J ) ) 170 CONTINUE 180 CONTINUE END IF DO 230, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 190, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 190 CONTINUE ELSE DO 200, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 200 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 210, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 210 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 220, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 220 CONTINUE 230 CONTINUE * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL CGEMM ( TRANSA, 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 240 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*C. Left, Lower, No transpose. * SMALLN = .NOT.CGB90( CIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.CGB90( CIP82, M, N ) DO 280, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 250, J = 1, N CALL CTRMV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 250 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. * DO 260, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 260 CONTINUE * * C := T3*C, triangular matrix multiply involving * a lower triangular diagonal block of A stored * in T3. * DO 270, J = 1, N CALL CTRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 270 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 280 CONTINUE ELSE DELTA = ALPHA CLDC = CGB91( LDC ) DO 350, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 290, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 290 CONTINUE DO 340, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 300, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 300 CONTINUE ELSE DO 310, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in CGEMV that appears if the second * dimension (tsec) is zero. * DO 320, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 320 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 330, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 330 CONTINUE 340 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 350 CONTINUE END IF ELSE * * Form C := alpha*A'*C or C := alpha*conjg( A' )*C. * Left, Lower, Transpose or Conjugated transpose * SMALLN = .NOT.CGB90( CIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.CGB90( CIP82, M, N ) DO 390, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( TRANSA, 'N', ISEC, N, 0, ZERO, A, $ LDA, C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C or C := conjg( A' )*C, triangular * matrix multiply involving a lower triangular * diagonal block of A. * DO 360, J = 1, N CALL CTRMV ( 'L', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 360 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to part of T3. * DO 370, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 370 CONTINUE * * C := T3'*C or C := conjg( T3' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A stored in T3. * DO 380, J = 1, N CALL CTRMV ( 'L', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 380 CONTINUE END IF * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 390 CONTINUE ELSE DELTA = ALPHA CLDC = CGB91( LDC ) DO 480, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A or T2 := conjg( A ), a unit or non-unit * lower triangular diagonal block of A is copied to * the lower triangular part of T2. * IF( NOCONJ )THEN DO 400, J = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-II+1+OFFD, J-II+1 ), 1 ) 400 CONTINUE ELSE DO 420, J = II, II+ISEC-1-OFFD DO 410, I = J+OFFD, II+ISEC-1 T2( I-II+1, J-II+1 ) = CONJG( A( I, J ) ) 410 CONTINUE 420 CONTINUE END IF DO 470, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 430, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 430 CONTINUE ELSE DO 440, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 440 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 450, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 450 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 460, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 480 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*C*A. Right, Upper, No transpose. * TINYM = .NOT.CGB90( CIP83, M, N ) IF( TINYM )THEN DO 500, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 490, I = 1, M CALL CTRMV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 500 CONTINUE ELSE DELTA = ALPHA DO 540, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) DO 530, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 510, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 510 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 520, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, C( II, J ), 1 ) 520 CONTINUE 530 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 540 CONTINUE END IF ELSE * * Form C := alpha*C*A' or C := alpha*C*conjg( A' ). * Right, Upper, Transpose or Conjugated transpose. * TINYM = .NOT.CGB90( CIP83, M, N ) IF( TINYM )THEN DO 570, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', TRANSA, M, JSEC, 0, ZERO, C, $ LDC, A, LDA, ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T3. * DO 550, J = JJ+OFFD, JJ+JSEC-1 CALL CCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T3( J-JJ+1, 1 ), RCB ) 550 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a upper triangular * diagonal block of T3. * DO 560, I = 1, M CALL CTRMV ( 'L', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 560 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 570 CONTINUE ELSE DELTA = ALPHA DO 640, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit upper triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 580, J = JJ+OFFD, JJ+JSEC-1 CALL CCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 580 CONTINUE ELSE DO 600, J = JJ+OFFD, JJ+JSEC-1 DO 590, I = JJ, J-OFFD T2( J-JJ+1, I-JJ+1 ) = CONJG( A( I, J ) ) 590 CONTINUE 600 CONTINUE END IF DO 630, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 610, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 610 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 620, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 620 CONTINUE 630 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 640 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*C*A. Right, Lower, No transpose. * TINYM = .NOT.CGB90( CIP83, M, N ) IF( TINYM )THEN DO 660, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * lower triangular diagonal block of A. * DO 650, I = 1, M CALL CTRMV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 650 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 660 CONTINUE ELSE DELTA = ALPHA DO 700, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 DO 690, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 670, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 670 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 680, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, C( II, J ), 1 ) 680 CONTINUE 690 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 700 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Lower, Transpose. * TINYM = .NOT.CGB90( CIP83, M, N ) IF( TINYM )THEN DO 730, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', TRANSA, M, JSEC, 0, ZERO, C, $ LDC, A, LDA, ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T3. * DO 710, J = JJ, JJ+JSEC-1-OFFD CALL CCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T3( J-JJ+1, J-JJ+1+OFFD ), RCB ) 710 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a lower triangular * diagonal block of T3. * DO 720, I = 1, M CALL CTRMV ( 'U', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 720 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a lower triangular * diagonal block of T3. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', TRANSA, M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 730 CONTINUE ELSE DELTA = ALPHA DO 800, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit lower triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 740, J = JJ, JJ+JSEC-1-OFFD CALL CCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 740 CONTINUE ELSE DO 760, J = JJ, JJ+JSEC-1-OFFD DO 750, I = J+OFFD, JJ+JSEC-1 T2( J-JJ+1, I-JJ+1 ) = CONJG( A( I, J ) ) 750 CONTINUE 760 CONTINUE END IF DO 790, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 770, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 770 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 780, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 780 CONTINUE 790 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', TRANSA, M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 800 CONTINUE END IF END IF END IF END IF * RETURN * * End of CGB08. * END SHAR_EOF fi # end of overwriting check if test -f 'cgb09.f' then echo shar: will not over-write existing file "'cgb09.f'" else cat << SHAR_EOF > 'cgb09.f' SUBROUTINE CGB09 ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC COMPLEX ALPHA * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGB09 (CTRSM) solves one of the matrix equations * * op( A )*X = alpha*C, or X*op( A ) = alpha*C, * * where alpha is a scalar, X and C are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * The matrix X is overwritten on C. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*C. * * SIDE = 'R' or 'r' X*op( A ) = alpha*C. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the right-hand side matrix C, and on exit is * overwritten by the solution matrix X. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOCONJ, NOUNIT, $ CLDC, SMALLN, TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC COMPLEX GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD, CONJG * .. External Functions .. LOGICAL LSAME, CGB90, CGB91 EXTERNAL LSAME, CGB90, CGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CGEMV, CTRSV, CCOPY * .. Parameters .. COMPLEX ZERO, ONE INTEGER CIP91, CIP92, CIP93 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ), $ CIP91 = 91, CIP92 = 92, CIP93 = 93 ) * .. User specified parameters for CGB09 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 7, RB = 5, CB = 3 ) COMPLEX T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( ( .NOT.NOTR ).AND.( .NOT.NOCONJ ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGB09 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL CGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Upper, No transpose. * SMALLN = .NOT.CGB90( CIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.CGB90( CIP92, M, N ) DO 40, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a upper triangular diagonal block of A. The * block of X is overwritten on C. * DO 10, J = 1, N CALL CTRSV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * Solve T3*X = C, triangular system solve * involving a upper triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 30, J = 1, N CALL CTRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF 40 CONTINUE ELSE DELTA = ONE CLDC = CGB91( LDC ) DO 110, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 80, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = II+ISEC-1-I TIJ = 1 IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE 110 CONTINUE END IF ELSE * * Solve A'*X = alpha*C or conjg( A' )*X = alpha*C. * Left, Upper, Transpose or Conjugated transpose. * SMALLN = .NOT.CGB90( CIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.CGB90( CIP92, M, N ) DO 150, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL CGEMM ( TRANSA, 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C or conjg( A' )*X = C, * triangular system solve involving a upper * triangular diagonal block of A. The block of X * is overwritten on C. * DO 120, J = 1, N CALL CTRSV ( 'U', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A, a unit or non-unit triangular diagonal * block of A is copied to T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 130 CONTINUE * * Solve T3'*X = C or conjg( T3' )*X = C, * triangular system solve involving a upper * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 140, J = 1, N CALL CTRSV ( 'U', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF 150 CONTINUE ELSE DELTA = ONE CLDC = CGB91( LDC ) DO 240, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL CGEMM ( TRANSA, 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * upper triangular diagonal block of A is copied to * the upper triangular part of T2. * IF( NOCONJ )THEN DO 160, J = II+OFFD, II+ISEC-1 CALL CCOPY ( J-II+1-OFFD, A( II, J ), 1, $ T2( 1, J-II+1 ), 1 ) 160 CONTINUE ELSE DO 180, J = II+OFFD, II+ISEC-1 DO 170, I = II, J-OFFD T2( I-II+1, J-II+1 ) = CONJG( A( I, J ) ) 170 CONTINUE 180 CONTINUE END IF DO 230, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 190, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 190 CONTINUE ELSE DO 200, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 200 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 210, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 210 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 220, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 220 CONTINUE 230 CONTINUE 240 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Lower, No transpose. * SMALLN = .NOT.CGB90( CIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.CGB90( CIP92, M, N ) DO 280, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL CGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a lower triangular diagonal block of A. The * block of X is overwritten on C. * DO 250, J = 1, N CALL CTRSV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 250 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. The block of X is * overwritten on C. * DO 260, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 260 CONTINUE * * Solve T3*X = C, triangular system solve * involving a lower triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 270, J = 1, N CALL CTRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 270 CONTINUE END IF 280 CONTINUE ELSE DELTA = ONE CLDC = CGB91( LDC ) DO 350, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL CGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 290, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 290 CONTINUE DO 340, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 300, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 300 CONTINUE ELSE DO 310, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 320, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 320 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 330, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 330 CONTINUE 340 CONTINUE 350 CONTINUE END IF ELSE * * Solve A'*X = alpha*C or conjg( A' )*X = alpha*C. * Left, Lower, Transpose or Conjugated transpose. * SMALLN = .NOT.CGB90( CIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.CGB90( CIP92, M, N ) DO 390, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C or conjg( A' )*X = C, * triangular system solve involving a lower * triangular diagonal block of A. The block of X * is overwritten on C. * DO 360, J = 1, N CALL CTRSV ( 'L', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 360 CONTINUE ELSE * * T3 := A, a unit or non-unit triangular diagonal * block of A is copied to T3. * DO 370, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 370 CONTINUE * * Solve T3'*X = C or conjg( T3' )*X = C, * triangular system solve involving a lower * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 380, J = 1, N CALL CTRSV ( 'L', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 380 CONTINUE END IF 390 CONTINUE ELSE DELTA = ONE CLDC = CGB91( LDC ) DO 480, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * lower triangular diagonal block of A is copied to * the lower triangular part of T2. * IF( NOCONJ )THEN DO 400, J = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-II+1+OFFD, J-II+1 ), 1 ) 400 CONTINUE ELSE DO 420, J = II, II+ISEC-1-OFFD DO 410, I = J+OFFD, II+ISEC-1 T2( I-II+1, J-II+1 ) = CONJG( A( I, J ) ) 410 CONTINUE 420 CONTINUE END IF DO 470, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 430, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 430 CONTINUE ELSE DO 440, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 440 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 450, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 450 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 460, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE 480 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Upper, No transpose. * TINYM = .NOT.CGB90( CIP93, M, N ) IF( TINYM )THEN DO 500, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a upper triangular diagonal block of A. The block * of X is overwritten on C. * DO 490, I = 1, M CALL CTRSV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE 500 CONTINUE ELSE DELTA = ONE DO 550, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 540, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 510, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 510 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 520, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 520 CONTINUE * * C := T1, T1 is copied back to C. * DO 530, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 530 CONTINUE 540 CONTINUE 550 CONTINUE END IF ELSE * * Solve X*A' = alpha*C or X*conjg( A' ) = alpha*C. * Right, Upper, Transpose or Conjugated transpose. * TINYM = .NOT.CGB90( CIP93, M, N ) IF( TINYM )THEN DO 580, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to T3. * DO 560, J = JJ+OFFD, JJ+JSEC-1 CALL CCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T3( J-JJ+1, 1 ), RCB ) 560 CONTINUE * * Solve X*T3' = C or X*conjg( T3' ) = C, triangular * system solve involving the transpose of a upper * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 570, I = 1, M CALL CTRSV ( 'L', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 570 CONTINUE 580 CONTINUE ELSE DELTA = ONE DO 660, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit upper triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 590, J = JJ+OFFD, JJ+JSEC-1 CALL CCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 590 CONTINUE ELSE DO 610, J = JJ+OFFD, JJ+JSEC-1 DO 600, I = JJ, J-OFFD T2( J-JJ+1, I-JJ+1 ) = CONJG( A( I, J ) ) 600 CONTINUE 610 CONTINUE END IF DO 650, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 620, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 620 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 630, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 630 CONTINUE * * C := T1, T1 is copied back to C. * DO 640, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 640 CONTINUE 650 CONTINUE 660 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Lower, No transpose. * TINYM = .NOT.CGB90( CIP93, M, N ) IF( TINYM )THEN DO 680, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a lower triangular diagonal block of A. The block * of X is overwritten on C. * DO 670, I = 1, M CALL CTRSV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 670 CONTINUE 680 CONTINUE ELSE DELTA = ONE DO 730, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 720, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 690, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 690 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 700, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 700 CONTINUE * * C := T1, T1 is copied back to C. * DO 710, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 710 CONTINUE 720 CONTINUE 730 CONTINUE END IF ELSE * * Solve X*A' = alpha*C or X*conjg( A' ) = alpha*C. * Right, Lower, Transpose or Conjugated transpose. * TINYM = .NOT.CGB90( CIP93, M, N ) IF( TINYM )THEN DO 760, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL CGEMM ( 'N', TRANSA, M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to T3. * DO 740, J = JJ, JJ+JSEC-1-OFFD CALL CCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T3( J-JJ+1, J-JJ+1+OFFD ), RCB ) 740 CONTINUE * * Solve X*T3' = C or X*conjg( T3' ) = C, triangular * system solve involving the transpose of a lower * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 750, I = 1, M CALL CTRSV ( 'U', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 750 CONTINUE 760 CONTINUE ELSE DELTA = ONE DO 840, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL CGEMM ( 'N', TRANSA, M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit lower triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 770, J = JJ, JJ+JSEC-1-OFFD CALL CCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 770 CONTINUE ELSE DO 790, J = JJ, JJ+JSEC-1-OFFD DO 780, I = J+OFFD, JJ+JSEC-1 T2( J-JJ+1, I-JJ+1 ) = CONJG( A( I, J ) ) 780 CONTINUE 790 CONTINUE END IF DO 830, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 800, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 800 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 810, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 810 CONTINUE * * C := T1, T1 is copied back to C. * DO 820, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 820 CONTINUE 830 CONTINUE 840 CONTINUE END IF END IF END IF END IF * RETURN * * End of CGB09. * END SHAR_EOF fi # end of overwriting check if test -f 'cgb90.f' then echo shar: will not over-write existing file "'cgb90.f'" else cat << SHAR_EOF > 'cgb90.f' LOGICAL FUNCTION CGB90 ( IP, DIM1, DIM2 ) * .. Scalar Arguments .. INTEGER IP, DIM1, DIM2 * .. * * Purpose * ======= * * CGB90 determines which of two alternative code sections in a GEMM- * Based Level 3 BLAS routine that will be the fastest for a particular * problem. If the problem is considered large enough CGB90 returns * .TRUE., otherwise .FALSE. is returned. The input parameter IP * specifies the calling routine and a break point for alternative code * sections. The input parameters DIM1 and DIM2 are matrix dimensions. * The returned value is a function of the input parameters and the * performance characteristics of the two alternative code sections. * * In this simple implementation, the returned values are determined by * looking at only one of the two dimensions DIM1 and DIM2. It may be * rewarding to rewrite the logical expressions in CGB90 so that both * dimensions are involved. The returned values should effectively * reflect the performance characteristics of the underlying BLAS * routines. * * * Input * ===== * * IP - INTEGER * On entry, IP specifies which routine and which alternative * code sections that the decision is intended for. * Unchanged on exit. * * DIM1 - INTEGER. * On entry, DIM1 specifies the first dimension in the calling * sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * DIM2 - INTEGER. * On entry, DIM2 specifies the second dimension in the * calling sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. User specified parameters for CGB90 .. INTEGER CIP41, CIP42, $ CIP51, CIP52, $ CIP81, CIP82, CIP83, $ CIP91, CIP92, CIP93 PARAMETER ( CIP41 = 4, CIP42 = 3, $ CIP51 = 4, CIP52 = 3, $ CIP81 = 4, CIP82 = 3, CIP83 = 4, $ CIP91 = 4, CIP92 = 3, CIP93 = 4 ) * .. * .. Executable Statements .. IF( IP.EQ.41 )THEN CGB90 = DIM1.GE.CIP41 ELSE IF( IP.EQ.42 )THEN CGB90 = DIM2.GE.CIP42 ELSE IF( IP.EQ.51 )THEN CGB90 = DIM1.GE.CIP51 ELSE IF( IP.EQ.52 )THEN CGB90 = DIM2.GE.CIP52 ELSE IF( IP.EQ.81 )THEN CGB90 = DIM2.GE.CIP81 ELSE IF( IP.EQ.82 )THEN CGB90 = DIM2.GE.CIP82 ELSE IF( IP.EQ.83 )THEN CGB90 = DIM1.GE.CIP83 ELSE IF( IP.EQ.91 )THEN CGB90 = DIM2.GE.CIP91 ELSE IF( IP.EQ.92 )THEN CGB90 = DIM2.GE.CIP92 ELSE IF( IP.EQ.93 )THEN CGB90 = DIM1.GE.CIP93 ELSE CGB90 = .FALSE. END IF * RETURN * * End of CGB90. * END SHAR_EOF fi # end of overwriting check if test -f 'cgb91.f' then echo shar: will not over-write existing file "'cgb91.f'" else cat << SHAR_EOF > 'cgb91.f' LOGICAL FUNCTION CGB91 ( LD ) * .. Scalar Arguments .. INTEGER LD * .. * * Purpose * ======= * * The size of the leading dimension of a two-dimensional array may * cause severe problems. Often when an array with a 'critical' leading * dimension is referenced, the execution time becomes significantly * longer than expected. This is caused by shortcomings of the memory * system. * * The function CGB91 returns .TRUE. if the leading dimension LD is * critical and .FALSE. if it is not critical. In this implementation * CGB91 is designed to detect critical leading dimensions in an * environment with a multi-way associative cache. Parameters defining * cache characteristics are adjustable to match different machines. * It may be rewarding to rewrite CGB91 for a machine with a different * cache policy. * * The cache lines in a multi-way associative cache are divided among a * number of partitions, each containing the same number of lines. Each * address of main memory is mapped into a particular partition. The * number of lines in a partition equals the associativity. For example, * in a four way associative cache, each partition contain four cache * lines. * * Data are transferred between the cache and main memory according to * an associative mapping scheme. A transfer of a data word from main * memory to cache is accomplished as follows. A unit of data * (data line) in main memory, with the size of a cache line, and * containing several contiguous data words including the referenced * one, is mapped (copied) to a certain partition in the cache memory. * The partition is determined by the location of the element in the * main memory and the associative mapping scheme. A replacement * algorithm makes room for the data line in one of the cache lines in * the selected partition. For example, an LRU-based (Least Recently * Used) replacement algorithm places the data line in the least * recently 'touched' cache line in the selected partition. * * * Input * ===== * * LD - On entry, LD specifies the leading dimension of a * 2-dimensional array. Unchanged on exit. * * * User specified parameters for CGB91 * ================================ * * LNSZ - Size of a cache line in number of bytes. * * NPRT - Number of partitions in the cache memory. * * PRTSZ - The number of cache lines in a partition that can be used * exclusively to hold a local array containing a matrix block * during the execution of a GEMM-Based Level 3 BLAS routine. * The remaining cache lines may be occupied by scalars, * vectors and possibly program code depending on the system. * * LOLIM - Leading dimensions smaller than or equal to LOLIM are not * considered critical. * * CP - Number of bytes in a complex-precision word. * * * Local Variables and Parameters * ============================== * * ONEWAY - The maximum number of real words that can be * stored in the cache memory if only a single cache line in * each partition may be used. * * UPDIF - The difference between the multiple of LD that is nearest * ONEWAY, or nearest a multiple of ONEWAY, and the nearest * multiple of ONEWAY that is larger than LD. In number of * real words. * * MXDIF - If both UPDIF and LD - UPDIF are less than MXDIF, and LD * is greater than LOLIM, then the leading dimension is * considered critical. Otherwise, the leading dimension is * considered not critical. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Variables .. INTEGER UPDIF * .. Intrinsic Functions .. INTRINSIC MIN, MOD * .. User specified parameters for CGB91 .. INTEGER LOLIM, LNSZ, NPRT, PRTSZ, CP PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, CP = 8 ) * .. Parameters .. INTEGER ONEWAY, MXDIF PARAMETER ( ONEWAY = ( LNSZ*NPRT )/CP, $ MXDIF = LNSZ/( CP*PRTSZ ) ) * .. * .. Executable Statements .. * IF( LD.LE.LOLIM )THEN CGB91 = .FALSE. ELSE UPDIF = MOD( ( LD/ONEWAY )*ONEWAY+ONEWAY, LD ) CGB91 = MIN( UPDIF, LD-UPDIF ).LE.MXDIF END IF * RETURN * * End of CGB91. * END SHAR_EOF fi # end of overwriting check if test -f 'cgbt01.f' then echo shar: will not over-write existing file "'cgbt01.f'" else cat << SHAR_EOF > 'cgbt01.f' SUBROUTINE CGBT01( CB3LIB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXTRNS, MXDIM, MXLDA, RUNS, RES ) * .. Scalar Arguments .. CHARACTER CB3LIB INTEGER LD, NMAX, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS COMPLEX ALPHA, BETA * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXTRNS ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) COMPLEX A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ) REAL RES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, MXDIM, $ MXLDA ) * * * Time all routines except CGEMM in the Level 3 BLAS library specified * by the input parameters. The library is either a user-supplied * Level 3 BLAS library or the GEMM-Based Level 3 BLAS library included * in the benchmark (CGB02, CGB04, CGB04, CGB05, CGB06, CGB07, CGB08, * and CGB09). Return the performance in Mflops for each problem * configuration. * * CGBT01 calls a REAL function SECOND with no arguments, * which is assumed to return the user time for a process in seconds * from some fixed starting-time. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, J, M, N, K, ADDS, MULTS, NOPS, $ D, L, R, OP1, OP2, OP3, OP4 REAL TIME, SPEED, TM0, TM1, TM2, TM3, TM4, TM5, TM6, $ TM7, TM8, TM9, TM10, TM11, TM12, TM13, TM14, $ TM15, TM16, TM17 * .. Intrinsic Functions .. INTRINSIC REAL, CMPLX, MIN * .. External Functions .. LOGICAL LSAME REAL SECOND EXTERNAL LSAME, SECOND * .. External Subroutines .. EXTERNAL CSYMM, CHEMM, CSYRK, CHERK, CSYR2K, CHER2K, $ CTRMM, CTRSM, $ CGB02, CGB03, CGB04, CGB05, CGB06, CGB07, $ CGB08, CGB09 * .. Parameters .. REAL ZERO, SCALE COMPLEX C11 * .. Parameter Values .. PARAMETER ( ZERO = 0.0E+0, SCALE = 1.0E+6, $ C11 = ( 1.0E+0, 1.0E+0 ) ) * .. * .. Executable Statements .. TM0 = SECOND( ) TM0 = SECOND( ) TM0 = SECOND( ) TM1 = SECOND( ) * * ------ Stop indentation ------ * DO 390, L = 1, NLDA DO 380, OP1 = 1, NSIDE DO 370, OP2 = 1, NUPLO DO 360, OP3 = 1, NTRNS DO 350, OP4 = 1, NDIAG DO 340, D = 1, NDIM * * ------ Continue indentation ------ * RES( 1, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 2, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 3, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 4, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 5, OP1, OP2, OP3, OP4, D, L ) = ZERO DO 330, R = 1, RUNS IF( LSAME( CB3LIB, 'U' ) )THEN * * Time the user-supplied library. Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 20, J = 1, NMAX DO 10, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 10 CONTINUE 20 CONTINUE TM2 = SECOND( ) CALL CSYMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM3 = SECOND( ) END IF IF( TABSUB( 2 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 40, J = 1, NMAX DO 30, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 30 CONTINUE 40 CONTINUE TM4 = SECOND( ) CALL CHEMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM5 = SECOND( ) END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 60, J = 1, NMAX DO 50, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 50 CONTINUE 60 CONTINUE TM6 = SECOND( ) CALL CSYRK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), $ BETA, C, LDA( L ) ) TM7 = SECOND( ) END IF IF( TABSUB( 4 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 80, J = 1, NMAX DO 70, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 70 CONTINUE 80 CONTINUE TM8 = SECOND( ) CALL CHERK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), REAL( ALPHA ), A, LDA( L ), $ REAL( BETA ), C, LDA( L ) ) TM9 = SECOND( ) END IF IF( TABSUB( 5 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 100, J = 1, NMAX DO 90, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 90 CONTINUE 100 CONTINUE TM10 = SECOND( ) CALL CSYR2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM11 = SECOND( ) END IF IF( TABSUB( 6 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 120, J = 1, NMAX DO 110, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 110 CONTINUE 120 CONTINUE TM12 = SECOND( ) CALL CHER2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ REAL( BETA ), C, LDA( L ) ) TM13 = SECOND( ) END IF IF( TABSUB( 7 ) )THEN DO 140, J = 1, NMAX DO 130, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 130 CONTINUE 140 CONTINUE TM14 = SECOND( ) CALL CTRMM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM15 = SECOND( ) END IF IF( TABSUB( 8 ) )THEN DO 160, J = 1, NMAX DO 150, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 150 CONTINUE 160 CONTINUE TM16 = SECOND( ) CALL CTRSM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM17 = SECOND( ) END IF ELSE IF( LSAME( CB3LIB, 'G' ) )THEN * * Time the built-in GEMM-Based Level 3 BLAS library (SGB02, * SGB04, SGB06, SGB08, and SGB09). Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 180, J = 1, NMAX DO 170, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 170 CONTINUE 180 CONTINUE TM2 = SECOND( ) CALL CGB02( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM3 = SECOND( ) END IF IF( TABSUB( 2 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 200, J = 1, NMAX DO 190, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 190 CONTINUE 200 CONTINUE TM4 = SECOND( ) CALL CGB03( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM5 = SECOND( ) END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 220, J = 1, NMAX DO 210, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 210 CONTINUE 220 CONTINUE TM6 = SECOND( ) CALL CGB04( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), $ BETA, C, LDA( L ) ) TM7 = SECOND( ) END IF IF( TABSUB( 4 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 240, J = 1, NMAX DO 230, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 230 CONTINUE 240 CONTINUE TM8 = SECOND( ) CALL CGB05( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), REAL( ALPHA ), A, LDA( L ), $ REAL( BETA ), C, LDA( L ) ) TM9 = SECOND( ) END IF IF( TABSUB( 5 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 260, J = 1, NMAX DO 250, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 250 CONTINUE 260 CONTINUE TM10 = SECOND( ) CALL CGB06( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM11 = SECOND( ) END IF IF( TABSUB( 6 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 280, J = 1, NMAX DO 270, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 270 CONTINUE 280 CONTINUE TM12 = SECOND( ) CALL CGB07( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ REAL( BETA ), C, LDA( L ) ) TM13 = SECOND( ) END IF IF( TABSUB( 7 ) )THEN DO 300, J = 1, NMAX DO 290, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 290 CONTINUE 300 CONTINUE TM14 = SECOND( ) CALL CGB08( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM15 = SECOND( ) END IF IF( TABSUB( 8 ) )THEN DO 320, J = 1, NMAX DO 310, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 310 CONTINUE 320 CONTINUE TM16 = SECOND( ) CALL CGB09( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM17 = SECOND( ) END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown Level 3 BLAS library choosen: ', CB3LIB, '.' END IF * * Compute the performance of CSYMM in Mflops. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM3 - TM2 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN MULTS = ( M + 1 )*M*N + MIN( M*N, ( M*( M+1 ) )/2 ) ADDS = M*M*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN MULTS = ( N + 1 )*M*N + MIN( M*N, ( N*( N+1 ) )/2 ) ADDS = M*N*N NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 1, OP1, OP2, 1, 1, D, L ).LT.SPEED )THEN RES( 1, OP1, OP2, 1, 1, D, L ) = SPEED END IF END IF * * Compute the performance of CHEMM in Mflops. * IF( TABSUB( 2 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM5 - TM4 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN MULTS = ( 6*M + 2 )*M*N + MIN( 6*M*N, 3*M*M - M ) ADDS = 2*M*M*N NOPS = MULTS + ADDS ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN MULTS = ( 6*N + 2 )*M*N + MIN( 6*M*N, 3*N*N - N ) ADDS = 2*M*N*N NOPS = MULTS + ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 2, OP1, OP2, 1, 1, D, L ).LT.SPEED )THEN RES( 2, OP1, OP2, 1, 1, D, L ) = SPEED END IF END IF * * Compute the performance of CSYRK in Mflops. * IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN TIME = ( TM7 - TM6 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( K + 1 )*( N*( N+1 )/2 ) + MIN( N*K, N*( N+1 )/2 ) ADDS = K*( N*( N+1 )/2 ) NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 3, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 3, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of CHERK in Mflops. * IF( TABSUB( 4 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN TIME = ( TM9 - TM8 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( 3*K + 1 )*N*N + MIN( 2*N*K, N*N ) ADDS = K*N*N NOPS = MULTS + ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 4, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 4, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of CSYR2K in Mflops. * IF( TABSUB( 5 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN TIME = ( TM11 - TM10 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( 2*K + 1 )*( N*( N+1 )/2 ) + $ MIN( 2*N*K, N*( N+1 ) ) ADDS = K*N*( N+1 ) NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 5, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 5, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of CHER2K in Mflops. * IF( TABSUB( 6 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN TIME = ( TM13 - TM12 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( 6*K + 1 )*N*N + MIN( 12*N*K, 6*N*N - 2*N ) ADDS = 2*K*N*N NOPS = MULTS + ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 6, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 6, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of CTRMM in Mflops. * IF( TABSUB( 7 ) )THEN TIME = ( TM15 - TM14 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN MULTS = ( ( M*( M + 1 ) )/2 )*N + $ MIN( M*N, ( M*( M + 1 ) )/2 ) ADDS = ( ( M*( M - 1 ) )/2 )*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN MULTS = ( ( M*( M - 1 ) )/2 )*N + $ MIN( M*N, ( M*( M + 1 ) )/2 ) ADDS = ( ( M*( M - 1 ) )/2 )*N NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN MULTS = ( M*( N*( N + 1 ) )/2 ) + $ MIN( M*N, ( N*( N + 1 ) )/2 ) ADDS = M*( N*( N - 1 ) )/2 NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN MULTS = ( M*( N*( N - 1 ) )/2 ) + $ MIN( M*N, ( N*( N + 1 ) )/2 ) ADDS = M*( N*( N - 1 ) )/2 NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 7, OP1, OP2, OP3, OP4, D, L ).LT.SPEED )THEN RES( 7, OP1, OP2, OP3, OP4, D, L ) = SPEED END IF END IF * * Compute the performance of CTRSM in Mflops. * IF( TABSUB( 8 ) )THEN TIME = ( TM17 - TM16 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN MULTS = ( ( M*( M + 1 ) )/2 )*N + $ MIN( M*N, ( M*( M + 1 ) )/2 ) ADDS = ( ( M*( M - 1 ) )/2 )*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN MULTS = ( ( M*( M - 1 ) )/2 )*N + $ MIN( M*N, ( M*( M + 1 ) )/2 ) ADDS = ( ( M*( M - 1 ) )/2 )*N NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN MULTS = ( M*( N*( N + 1 ) )/2 ) + $ MIN( M*N, ( N*( N + 1 ) )/2 ) ADDS = M*( N*( N - 1 ) )/2 NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN MULTS = ( M*( N*( N - 1 ) )/2 ) + $ MIN( M*N, ( N*( N + 1 ) )/2 ) ADDS = M*( N*( N - 1 ) )/2 NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 8, OP1, OP2, OP3, OP4, D, L ).LT.SPEED )THEN RES( 8, OP1, OP2, OP3, OP4, D, L ) = SPEED END IF END IF 330 CONTINUE * * ------ Stop indentation ------ * 340 CONTINUE 350 CONTINUE 360 CONTINUE 370 CONTINUE 380 CONTINUE 390 CONTINUE * * ------ Continue indentation ------ * RETURN * * End of CGBT01. * END SHAR_EOF fi # end of overwriting check if test -f 'cgbt02.f' then echo shar: will not over-write existing file "'cgbt02.f'" else cat << SHAR_EOF > 'cgbt02.f' SUBROUTINE CGBT02( TABSUB, SIDE, NSIDE, NUPLO, TRNS, NTRNS, NDIAG, $ DIM1, DIM2, NDIM, LDA, NLDA, ALPHA, BETA, $ A, B, C, LD, NMAX, NERR, MXSUB, MXOPT, $ MXTRNS, MXDIM, MXLDA, RUNS, RES ) * .. Scalar Arguments .. INTEGER LD, NMAX, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS COMPLEX ALPHA, BETA * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER SIDE( MXOPT ), TRNS( MXTRNS ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) COMPLEX A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ) REAL RES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, MXDIM, $ MXLDA ) * * * Determine problem configurations for CGEMM that, for timing purposes, * "correspond" to problem configurations for the remaining Level 3 BLAS * routines. Time CGEMM for problems that correspond to the Level 3 BLAS * problems timed in CGBT01. Return the performance of CGEMM in Mflops. * * CGBT02 calls a REAL function SECOND with no arguments, * which is assumed to return the user time for a process in seconds * from some fixed starting-time. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, J, M, N, K, ADDS, MULTS, NOPS, $ D, L, R, OP1, OP2, OP3, OP4 REAL TIME, SPEED, TM0, TM1, TM2, TM3, TM4, TM5, TM6, $ TM7, TM8, TM9, TM10, TM11, TM12, TM13 * .. Intrinsic Functions .. INTRINSIC REAL, CMPLX, MIN * .. External Functions .. LOGICAL LSAME REAL SECOND EXTERNAL LSAME, SECOND * .. External Subroutines .. EXTERNAL CGEMM * .. Parameters .. REAL ZERO, SCALE COMPLEX ONE, C11 PARAMETER ( ZERO = 0.0E+0, SCALE = 1.0E+6, $ ONE = ( 1.0E+0, 0.0E+0 ), $ C11 = ( 1.0E+0, 1.0E+0 ) ) * .. * .. Executable Statements .. TM0 = SECOND( ) TM0 = SECOND( ) TM0 = SECOND( ) TM1 = SECOND( ) * * ------ Stop indentation ------ * DO 240, L = 1, NLDA DO 230, OP1 = 1, NSIDE DO 220, OP3 = 1, NTRNS DO 210, D = 1, NDIM * * ------ Continue indentation ------ * RES( 1, OP1, 1, OP3, 1, D, L ) = ZERO RES( 2, OP1, 1, OP3, 1, D, L ) = ZERO RES( 3, OP1, 1, OP3, 1, D, L ) = ZERO RES( 4, OP1, 1, OP3, 1, D, L ) = ZERO RES( 5, OP1, 1, OP3, 1, D, L ) = ZERO DO 200, R = 1, RUNS * * Time the user-supplied library. Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( ( TABSUB( 1 ).OR.TABSUB( 2 ) ).AND.OP3.EQ.1 )THEN DO 20, J = 1, NMAX DO 10, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 10 CONTINUE 20 CONTINUE * * Time CGEMM for a problem that corresponds to the following * problem for CSYMM or CHEMM: * CSYMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) * IF( LSAME( SIDE( OP1 ), 'L' ) )THEN * * Use K = M. * TM2 = SECOND( ) CALL CGEMM( 'N', 'N', DIM1( D ), DIM2( D ), DIM1( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM3 = SECOND( ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN * * Use K = N. * TM2 = SECOND( ) CALL CGEMM( 'N', 'N', DIM1( D ), DIM2( D ), DIM2( D ), $ ALPHA, B, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM3 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' STOP END IF END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 40, J = 1, NMAX DO 30, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 30 CONTINUE 40 CONTINUE * * Time CGEMM for a problem that corresponds to the following * problem for CSYRK: * CSYRK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), BETA, C, LDA( L ) ) * Use M = N and B = A in the call to CGEMM. * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM4 = SECOND( ) CALL CGEMM( 'N', 'T', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM5 = SECOND( ) ELSE IF( LSAME( TRNS( OP3 ), 'T' ) )THEN TM4 = SECOND( ) CALL CGEMM( 'T', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM5 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 4 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 60, J = 1, NMAX DO 50, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 50 CONTINUE 60 CONTINUE * * Time CGEMM for a problem that corresponds to the following * problem for CHERK: * CHERK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * REAL( ALPHA ), A, LDA( L ), REAL( BETA ), C, LDA( L ) ) * Use M = N and B = A in the call to CGEMM. * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM6 = SECOND( ) CALL CGEMM( 'N', 'C', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM7 = SECOND( ) ELSE IF( LSAME( TRNS( OP3 ), 'C' ) )THEN TM6 = SECOND( ) CALL CGEMM( 'C', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM7 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 5 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 80, J = 1, NMAX DO 70, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 70 CONTINUE 80 CONTINUE * * Time CGEMM for a problem that corresponds to the following * problem for CSYR2K: * CSYR2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM8 = SECOND( ) CALL CGEMM( 'N', 'T', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM9 = SECOND( ) ELSE IF( LSAME( TRNS( OP3 ), 'T' ) )THEN TM8 = SECOND( ) CALL CGEMM( 'T', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM9 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 6 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 100, J = 1, NMAX DO 90, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 90 CONTINUE 100 CONTINUE * * Time CGEMM for a problem that corresponds to the following * problem for CHER2K: * CHER2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), * REAL( BETA ), C, LDA( L ) ) * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM10 = SECOND( ) CALL CGEMM( 'N', 'C', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM11 = SECOND( ) ELSE IF( LSAME( TRNS( OP3 ), 'C' ) )THEN TM10 = SECOND( ) CALL CGEMM( 'C', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM11 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 7 ).OR.TABSUB( 8 ) )THEN DO 120, J = 1, NMAX DO 110, I = 1, LD C( I, J ) = C11 + CMPLX( 0.01E+0* $ REAL( I+( J-1 )*NMAX )/ REAL( NMAX*NMAX+1 ), $ 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 110 CONTINUE 120 CONTINUE * * Time CGEMM for a problem that corresponds to the following * problems for CTRMM and CTRSM: * CTRMM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), * DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, * A, LDA( L ), C, LDA( L ) ) * CTRSM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), * DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, * A, LDA( L ), C, LDA( L ) ) * IF( LSAME( SIDE( OP1 ), 'L' ) )THEN * * C := alpha*A*C + C or C := alpha*A'*C + C. Use K = M. * TM12 = SECOND( ) CALL CGEMM( TRNS( OP3 ), 'N', DIM1( D ), DIM2( D ), $ DIM1( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ ONE, C, LDA( L ) ) TM13 = SECOND( ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN * * C := alpha*C*A + C or C := alpha*C*A' + C. Use K = N. * TM12 = SECOND( ) CALL CGEMM( 'N', TRNS( OP3 ), DIM1( D ), DIM2( D ), $ DIM2( D ), ALPHA, B, LDA( L ), A, LDA( L ), $ ONE, C, LDA( L ) ) TM13 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' STOP END IF END IF * * Compute the performance of CGEMM in Mflops for problem * configurations that corresponds to CSYMM or CHEMM. * IF( ( TABSUB( 1 ).OR.TABSUB( 2 ) ).AND.OP3.EQ.1 )THEN TIME = ( TM3 - TM2 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN MULTS = ( M + 1 )*M*N + MIN( M*N, M*M ) ADDS = M*M*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN MULTS = ( N + 1 )*M*N + MIN( M*N, N*N ) ADDS = M*N*N NOPS = 6*MULTS + 2*ADDS END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 1, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 130, OP2 = 1, NUPLO RES( 1, OP1, OP2, OP3, 1, D, L ) = SPEED RES( 2, OP1, OP2, OP3, 1, D, L ) = SPEED 130 CONTINUE END IF END IF * * Compute the performance of CGEMM in Mflops for problem * configurations that corresponds to CSYRK. * IF( TABSUB( 3 ).AND.OP1.EQ.1 )THEN TIME = ( TM5 - TM4 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( K + 1 )*N*N + MIN( N*K, N*N ) ADDS = K*N*N NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 3, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 140, OP2 = 1, NUPLO RES( 3, OP1, OP2, OP3, 1, D, L ) = SPEED 140 CONTINUE END IF END IF * * Compute the performance of CGEMM in Mflops for problem * configurations that corresponds to CHERK. * IF( TABSUB( 4 ).AND.OP1.EQ.1 )THEN TIME = ( TM7 - TM6 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( K + 1 )*N*N + MIN( N*K, N*N ) ADDS = K*N*N NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 4, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 150, OP2 = 1, NUPLO RES( 4, OP1, OP2, OP3, 1, D, L ) = SPEED 150 CONTINUE END IF END IF * * Compute the performance of CGEMM in Mflops for problem * configurations that corresponds to CSYR2K. * IF( TABSUB( 5 ).AND.OP1.EQ.1 )THEN TIME = ( TM9 - TM8 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( K + 1 )*N*N + MIN( N*K, N*N ) NOPS = K*N*N NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 5, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 160, OP2 = 1, NUPLO RES( 5, OP1, OP2, OP3, 1, D, L ) = SPEED 160 CONTINUE END IF END IF * * Compute the performance of CGEMM in Mflops for problem * configurations that corresponds to CHER2K. * IF( TABSUB( 6 ).AND.OP1.EQ.1 )THEN TIME = ( TM11 - TM10 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( K + 1 )*N*N + MIN( N*K, N*N ) NOPS = K*N*N NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 6, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 170, OP2 = 1, NUPLO RES( 6, OP1, OP2, OP3, 1, D, L ) = SPEED 170 CONTINUE END IF END IF * * Compute the performance of CGEMM in Mflops for problem * configurations that corresponds to CTRMM and CTRSM. * IF( TABSUB( 7 ).OR.TABSUB( 8 ) )THEN TIME = ( TM13 - TM12 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN MULTS = M*M*N + MIN( M*N, M*M ) ADDS = ( M - 1 )*M*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN MULTS = M*N*N + MIN( M*N, N*N ) ADDS = ( N - 1 )*M*N NOPS = 6*MULTS + 2*ADDS END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 7, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 190, OP2 = 1, NUPLO DO 180, OP4 = 1, NDIAG RES( 7, OP1, OP2, OP3, OP4, D, L ) = SPEED RES( 8, OP1, OP2, OP3, OP4, D, L ) = SPEED 180 CONTINUE 190 CONTINUE END IF END IF 200 CONTINUE * * ------ Stop indentation ------ * 210 CONTINUE 220 CONTINUE 230 CONTINUE 240 CONTINUE * * ------ Continue indentation ------ * RETURN * * End of SGBT02. * END SHAR_EOF fi # end of overwriting check if test -f 'cgbtim.f' then echo shar: will not over-write existing file "'cgbtim.f'" else cat << SHAR_EOF > 'cgbtim.f' * * GEMM-Based Level 3 BLAS Benchmark * COMPLEX * * The GEMM-Based Level 3 BLAS Benchmark is a tool for performance * evaluation of Level 3 BLAS kernel programs. With the announcement of * LAPACK, the need for high performance Level 3 BLAS kernels became * apparent. LAPACK is based on calls to the Level 3 BLAS kernels. This * benchmark measures and compares performance of a set of user supplied * Level 3 BLAS implementations and of the GEMM-Based Level 3 BLAS * implementations permanently included in the benchmark. The purpose of * the benchmark is to facilitate the user in determining the quality of * different Level 3 BLAS implementations. The included GEMM-Based * Level 3 BLAS routines provide a lower limit on the performance to be * expected from a highly optimized Level 3 BLAS library. * * All routines are written in Fortran 77 for portability. No changes to * the code should be necessary in order to run the programs correctly * on different target machines. In fact, we strongly recommend the user * to avoided changes, except to the user specified parameters and to * UNIT numbers for input and output communication. This will ensure * that performance results from different target machines are * comparable. * * The program calls a REAL function SECOND with no * arguments, which is assumed to return the user time for a process in * seconds from some fixed starting-time. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * PROGRAM CGBTIM * .. Parameters .. INTEGER NIN, NOUT, NERR, IERR PARAMETER ( NIN = 5, NOUT = 6, NERR = 6 ) INTEGER LD, NMAX PARAMETER ( LD = 530, NMAX = LD ) INTEGER LLN, LST, LNM PARAMETER ( LLN = 256, LST = 50, LNM = 6 ) INTEGER MXTAB, MXOPT, MXTRNS, MXDIM, MXLDA, MXSUB, $ MXRUNS PARAMETER ( MXTAB = 6, MXSUB = 8, MXOPT = 2, MXTRNS = 3, $ MXDIM = 36, MXLDA = 24, MXRUNS = 20 ) COMPLEX C11, ALPHA, BETA PARAMETER ( C11 = ( 1.0E+0, 1.0E+0 ), $ ALPHA = ( 0.9E+0, 0.05E+0 ), $ BETA = ( 1.1E+0, 0.03E+0 ) ) * .. Local Scalars .. INTEGER I, IB, IE, IX, J, JB, JE, KB, KE, $ NTAB, NSIDE, NUPLO, NTRNS, NDIAG, NDIM1, NDIM2, $ NLDA, NRUNS, RUNS, MATCH LOGICAL ERR1, ERR2, ERR3, ERR4, SUB * .. Intrinsic Functions .. INTRINSIC REAL, CMPLX * .. External Functions .. INTEGER EOLN LOGICAL LSAME, GETWRD EXTERNAL LSAME, GETWRD, EOLN * .. External Subroutines .. EXTERNAL CGBT01, CGBT02, CGBTP1, CGBTP2 * .. Local Arrays .. INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) LOGICAL SUBCHK( MXSUB ), TABSUB( MXSUB ), TAB( MXTAB ) COMPLEX A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ) REAL USRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ GBRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ) COMMON / CBKCMN / A, B, C, USRES, GBRES, MMRES CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXTRNS ), $ DIAG( MXOPT ) CHARACTER INLN*( LLN ), INSTR*( LST ), BLANK*( LST ), $ LBL*( LST ), NAME( MXSUB )*( LNM ) CHARACTER INLNA( LLN ) EQUIVALENCE ( INLN, INLNA ) * .. Data statements .. DATA NTAB/ 0 /, NRUNS/ 0 /, NSIDE/ 0 /, NUPLO/ 0 /, $ NTRNS/ 0 /, NDIAG/ 0 /, NDIM1/ 0 /, NDIM2/ 0 /, $ NLDA/ 0 / DATA TAB/ MXTAB*.FALSE. /, TABSUB/ MXSUB*.FALSE. /, $ SUBCHK/ MXSUB*.FALSE. /, $ SIDE/ MXOPT*' ' /, UPLO/ MXOPT*' '/, $ TRNS/ MXTRNS*' ' /, DIAG/ MXOPT*' '/, $ NAME/ 'CSYMM ', 'CHEMM ', 'CSYRK ', 'CHERK ', $ 'CSYR2K', 'CHER2K', 'CTRMM ', 'CTRSM '/, $ SUB/ .FALSE. / DATA BLANK/' '/, $ LBL /' '/ * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. Store the line in the variable INLN. The first word (token) * of the line is stored in INLN( IB:IE ). * 10 READ( NIN, FMT = 9000, END = 210 ) INLN IF( .NOT.GETWRD( INLN, LLN, IB, IE ).OR. $ ( INLN( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * If INLN( IB:IE ) contains the key word for a parameter, then read * and store the parameter values given on the same line of the input * file, after the key word. * JB = IB JE = IE I = 0 ERR1 = .FALSE. ERR2 = .FALSE. ERR3 = .FALSE. ERR4 = .FALSE. * * Read the parameters from the line INLN. * IF( INLN( JB:JE ).EQ.'LBL' )THEN * * Read the label of this test. * IF( LBL.NE.BLANK )THEN ERR3 = .TRUE. END IF IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN KE = EOLN( INLN( JE+1:LLN ), LLN-JE ) JB = JE + KB JE = JE + KE IF( JE-JB+1.GT.LST )THEN ERR4 = .TRUE. ELSE LBL = INLN( JB:JE ) END IF END IF I = 1 ELSE IF( INLN( JB:JE ).EQ.'TAB' )THEN * * Read which tests to be made. * IF( NTAB.NE.0 )THEN ERR3 = .TRUE. END IF 20 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXTAB )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) IX IF( IERR.GT.0.OR.IX.LT.1.OR.IX.GT.MXTAB )THEN ERR1 = .TRUE. END IF IF( TAB( IX ) )THEN ERR1 = .TRUE. END IF TAB( IX ) = .TRUE. ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 20 END IF END IF NTAB = I ELSE IF( INLN( JB:JE ).EQ.'RUNS' )THEN * * Read the number of times each problem is to be executed. The * final performance results are computed using the best timing * result for each problem. * IF( NRUNS.NE.0 )THEN ERR3 = .TRUE. END IF 30 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.1 )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) RUNS IF( IERR.GT.0.OR.RUNS.LT.1.OR.RUNS.GT.MXRUNS )THEN ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 30 END IF END IF NRUNS = I ELSE IF( INLN( IB:IE ).EQ.'SIDE' )THEN * * Read the values for SIDE. * IF( NSIDE.NE.0 )THEN ERR3 = .TRUE. END IF 40 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'L' ) )THEN DO 50, J = 1, I IF( LSAME( SIDE( J ), 'L' ) ) ERR1 = .TRUE. 50 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'R' ) )THEN DO 60, J = 1, I IF( LSAME( SIDE( J ), 'R' ) ) ERR1 = .TRUE. 60 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 SIDE( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 40 END IF END IF NSIDE = I ELSE IF( INLN( IB:IE ).EQ.'UPLO' )THEN * * Read the values for UPLO. * IF( NUPLO.NE.0 )THEN ERR3 = .TRUE. END IF 70 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'U' ) )THEN DO 80, J = 1, I IF( LSAME( UPLO( J ), 'U' ) ) ERR1 = .TRUE. 80 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'L' ) )THEN DO 90, J = 1, I IF( LSAME( UPLO( J ), 'L' ) ) ERR1 = .TRUE. 90 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 UPLO( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 70 END IF END IF NUPLO = I ELSE IF( INLN( IB:IE ).EQ.'TRANS' )THEN * * Read the values for TRANS. * IF( NTRNS.NE.0 )THEN ERR3 = .TRUE. END IF 100 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXTRNS )THEN IF( LSAME( INLN( JB:JB ), 'N' ) )THEN DO 110, J = 1, I IF( LSAME( TRNS( J ), 'N' ) ) ERR1 = .TRUE. 110 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'T' ) )THEN DO 120, J = 1, I IF( LSAME( TRNS( J ), 'T' ) ) ERR1 = .TRUE. 120 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'C' ) )THEN DO 130, J = 1, I IF( LSAME( TRNS( J ), 'C' ) ) ERR1 = .TRUE. 130 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 TRNS( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 100 END IF END IF NTRNS = I ELSE IF( INLN( IB:IE ).EQ.'DIAG' )THEN * * Read the values for DIAG. * IF( NDIAG.NE.0 )THEN ERR3 = .TRUE. END IF 140 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'N' ) )THEN DO 150, J = 1, I IF( LSAME( DIAG( J ), 'N' ) ) ERR1 = .TRUE. 150 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'U' ) )THEN DO 160, J = 1, I IF( LSAME( DIAG( J ), 'U' ) ) ERR1 = .TRUE. 160 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 DIAG( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 140 END IF END IF NDIAG = I ELSE IF( INLN( IB:IE ).EQ.'DIM1' )THEN * * Read the values for the first matrix dimension (DIM1). * IF( NDIM1.NE.0 )THEN ERR3 = .TRUE. END IF 170 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXDIM )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) DIM1( I ) IF( IERR.GT.0.OR.DIM1( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( DIM1( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 170 END IF END IF NDIM1 = I ELSE IF( INLN( IB:IE ).EQ.'DIM2' )THEN * * Read the values for the second matrix dimension (DIM2). * IF( NDIM2.NE.0 )THEN ERR3 = .TRUE. END IF 180 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXDIM )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) DIM2( I ) IF( IERR.GT.0.OR.DIM2( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( DIM2( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 180 END IF END IF NDIM2 = I ELSE IF( INLN( IB:IE ).EQ.'LDA' )THEN * * Read the values for leading dimension (LDA). * IF( NLDA.NE.0 )THEN ERR3 = .TRUE. END IF 190 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXLDA )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) LDA( I ) IF( IERR.GT.0.OR.LDA( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( LDA( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 190 END IF END IF NLDA = I ELSE IF( INLN( IB:IE ).EQ.'CSYMM'.OR.INLN( IB:IE ).EQ.'CHEMM'.OR. $ INLN( IB:IE ).EQ.'CSYRK'.OR.INLN( IB:IE ).EQ.'CHERK'.OR. $ INLN( IB:IE ).EQ.'CSYR2K'.OR.INLN( IB:IE ).EQ.'CHER2K'.OR. $ INLN( IB:IE ).EQ.'CTRMM'.OR.INLN( IB:IE ).EQ.'CTRSM' )THEN * * Read which routines to time. * MATCH = 0 DO 200, I = 1, MXSUB IF( NAME( I ).EQ.INLN( IB:IB+5 ) )THEN MATCH = I IF( SUBCHK( MATCH ) )THEN ERR3 = .TRUE. END IF SUBCHK( MATCH ) = .TRUE. END IF 200 CONTINUE IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE * * Time the routine if the first non-blank character * INLN( JB:JB ) is 'T' or 't'. * TABSUB( MATCH ) = LSAME( INLN( JB:JB ), 'T' ) IF( .NOT.( TABSUB( MATCH ).OR. $ LSAME( INLN( JB:JB ), 'F' ) ) )THEN ERR1 = .TRUE. END IF SUB = SUB.OR.TABSUB( MATCH ) I = 1 ELSE I = 0 END IF ELSE WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: Unknown parameter ', INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP END IF * IF( I.EQ.0 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: No values or erroneous values given ', $ 'for the parameter ', INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR1 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Erroneus value or too many values for the parameter ', $ INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR2 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Value too large for ', INLN( IB:IE ), '. Max ', NMAX, '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR3 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Multiple specifications of the input parameter ', $ INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR4 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = 9010 ) $ 'The label of this test is too long. Max ', LST, $ ' characters.' WRITE( NERR, FMT = * ) STOP END IF GO TO 10 * 210 CONTINUE IF( NTAB.LE.0 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: No results are chosen to be presented' WRITE( NERR, FMT = * ) $ ' (see the parameter TAB).' WRITE( NERR, FMT = * ) STOP END IF IF( ( TAB( 2 ).OR.TAB( 3 ).OR.TAB( 4 ).OR.TAB( 5 ).OR.TAB( 6 ) ) $ .AND.( NRUNS.LE.0.OR.NSIDE.LE.0.OR.NUPLO.LE.0.OR. $ NTRNS.LE.0.OR.NDIAG.LE.0.OR.NDIM1.LE.0.OR. $ NDIM2.LE.0.OR.NLDA.LE.0.OR.( .NOT.SUB ) ) )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: A parameter, or values for a parameter, is missing.' WRITE( NERR, FMT = * ) $ 'One (or more) of the input parameters RUNS, SIDE, UPLO,' WRITE( NERR, FMT = * ) $ 'TRANS, DIAG, DIM1, DIM2, LDA are missing, or none of the' WRITE( NERR, FMT = * ) $ 'routines CSYMM, CHEMM, CSYRK, CHERK, CSYR2K, CHER2K,' WRITE( NERR, FMT = * ) $ 'CTRMM, and CTRSM are marked to be timed', '.' WRITE( NERR, FMT = * ) STOP END IF IF( NDIM1.NE.NDIM2 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: Different number of dimensions ', $ 'for DIM1 and DIM2', '.' WRITE( NERR, FMT = * ) STOP END IF * * Initialize the matrices A and B. * DO 230, J = 1, NMAX DO 220, I = 1, NMAX A( I, J ) = C11 + CMPLX( 0.08E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ), 0.06E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 220 CONTINUE 230 CONTINUE DO 250, J = 1, NMAX DO 240, I = 1, NMAX B( I, J ) = C11 + CMPLX( 0.04E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ), 0.02E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) ) 240 CONTINUE 250 CONTINUE * * Time the routines and calculate the results. * IF( TAB( 2 ).OR.TAB( 6 ) )THEN * * Time the internal GEMM-Based Level 3 BLAS routines (CGB02, * CGB03, CGB04, CGB05, CGB06, CGB07, CGB08, and CGB09). * CALL CGBT01( 'G', TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXTRNS, MXDIM, MXLDA, RUNS, GBRES ) END IF IF( TAB( 1 ).OR.TAB( 3 ).OR.TAB( 5 ).OR.TAB( 6 ) )THEN * * Time the user-supplied Level 3 BLAS library. * CALL CGBT01( 'U', TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXTRNS, MXDIM, MXLDA, RUNS, USRES ) END IF IF( TAB( 1 ).OR.TAB( 4 ).OR.TAB( 5 ) )THEN * * Time CGEMM using user specified parameters. * CALL CGBT02( TABSUB, SIDE, NSIDE, NUPLO, TRNS, NTRNS, NDIAG, $ DIM1, DIM2, NDIM1, LDA, NLDA, ALPHA, BETA, $ A, B, C, LD, NMAX, NERR, MXSUB, MXOPT, $ MXTRNS, MXDIM, MXLDA, RUNS, MMRES ) END IF IF( TAB( 1 ) )THEN * * Calculate and print the collected benchmark result. * CALL CGBTP1( TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, NTRNS, $ DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, NOUT, $ NERR, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES ) END IF IF( TAB( 2 ).OR.TAB( 3 ).OR.TAB( 4 ).OR.TAB( 5 ).OR.TAB( 6 ) )THEN * * Calculate and print the results of TAB choice 2 - 6. * CALL CGBTP2( TAB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ NOUT, MXTAB, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, $ RUNS, ALPHA, BETA, LBL, USRES, MMRES, GBRES ) END IF * STOP * 9000 FORMAT( A ) 9010 FORMAT( 1X, A, I3, A ) 9020 FORMAT( I50 ) * * End of CGBTIM. * END SHAR_EOF fi # end of overwriting check if test -f 'cgbtp1.f' then echo shar: will not over-write existing file "'cgbtp1.f'" else cat << SHAR_EOF > 'cgbtp1.f' SUBROUTINE CGBTP1( TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, NTRNS, $ DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, NOUT, $ NERR, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, $ RUNS, ALPHA, BETA, LBL, USRES, MMRES ) * .. Scalar Arguments .. INTEGER NOUT, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS COMPLEX ALPHA, BETA * .. Parameters .. INTEGER LST PARAMETER ( LST = 50 ) * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER LBL*( LST ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXTRNS ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) REAL USRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ) * * * CGBTP1 prints the collected benchmark result which is calculated from * performance results of the user-supplied Level 3 routines for * problems specified in the input file. The result consists of a tuple * ( x, y ), where x is the mean value of the GEMM-Efficiency and y is * the mean value of the performance of CGEMM in megaflops. CGEMM is * timed for problems corresponding to those specified for the remaining * Level 3 routines. * * The purpose of the collected benchmark result is to provide an * overall performance measure of the user-supplied Level 3 BLAS * routines. The intention is to expose the capacity of the target * machine for these kinds of problems and to show how well the routines * utilize the machine. Furthermore, the collected result is intended to * be easy to compare between different target machines. See the README * and INSTALL files for further information. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, D, L, NTIM, OP1, OP2, OP3 REAL SPEED, EFF, MM, MMSUM, EFSUM * .. Intrinsic Functions .. INTRINSIC REAL * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. Parameters .. REAL ZERO INTEGER MXBSUB PARAMETER ( ZERO = 0.0E+0, MXBSUB = 8 ) * .. * .. Executable Statements .. IF( MXSUB.GT.MXBSUB )THEN WRITE( NERR, FMT = 9000 ) STOP END IF * MMSUM = ZERO EFSUM = ZERO NTIM = 0 * * ------ Stop indentation ------ * DO 50, L = 1, NLDA DO 40, OP1 = 1, NSIDE DO 30, OP2 = 1, NUPLO DO 20, OP3 = 1, NTRNS DO 10, D = 1, NDIM * * ------ Continue indentation ------ * * * Compute the sum of the performance of CGEMM in megaflops (MMSUM) * and the sum of the GEMM-Efficiency (EFSUM). * IF( TABSUB( 1 ).AND.OP3.EQ.1 )THEN MM = MMRES( 1, OP1, OP2, 1, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 1, OP1, OP2, 1, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 2 ).AND.OP3.EQ.1 )THEN MM = MMRES( 2, OP1, OP2, 1, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 2, OP1, OP2, 1, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN MM = MMRES( 3, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 3, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 4 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN MM = MMRES( 4, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 4, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 5 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN MM = MMRES( 5, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 5, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 6 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN MM = MMRES( 6, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 6, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 7 ) )THEN MM = MMRES( 7, OP1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 7, OP1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 8 ) )THEN MM = MMRES( 8, OP1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 8, OP1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF * * ------ Stop indentation ------ * 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE * * ------ Continue indentation ------ * * * Compute the collected benchmark result ( x, y ) as the mean value * of the GEMM-Efficiency ( x ) and the mean value of the performance * of CGEMM in megaflops ( y ). * SPEED = MMSUM/REAL( NTIM ) EFF = EFSUM/REAL( NTIM ) * * Print an introduction and the collected benchmark result. * WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9020 ) WRITE( NOUT, FMT = 9030 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9040 ) RUNS WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9050 ) WRITE( NOUT, FMT = 9060 ) 'SIDE ', ( SIDE( I ), I = 1, NSIDE ) WRITE( NOUT, FMT = 9060 ) 'UPLO ', ( UPLO( I ), I = 1, NUPLO ) WRITE( NOUT, FMT = 9060 ) 'TRANS ', ( TRNS( I ), I = 1, NTRNS ) WRITE( NOUT, FMT = 9060 ) 'DIAG ', ( DIAG( I ), I = 1, NDIAG ) WRITE( NOUT, FMT = 9070 ) 'DIM1 ', ( DIM1( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9070 ) 'DIM2 ', ( DIM2( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9070 ) 'LDA ', ( LDA( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9080 ) 'ALPHA ', ALPHA WRITE( NOUT, FMT = 9080 ) 'BETA ', BETA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9090 ) LBL WRITE( NOUT, FMT = 9100 ) EFF, SPEED WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) * RETURN * * Print formats. * 9000 FORMAT( 1X, 'Error: The collected benchmark result could not ', $ 'be obtained.',/, $ 1X, 'The value for the input parameter MXSUB is too ', $ 'large.' ) 9010 FORMAT( 1X, 'Error: The collected benchmark result could not ', $ 'be obtained.',/, $ 1X, 'Execution time for CGEMM is zero.' ) 9020 FORMAT( 17X, '**** GEMM-Based Level 3 BLAS Benchmark ****' ) 9030 FORMAT( 27X, 'Collected Benchmark Result',/, $ 33X, ' Complex ' ) 9040 FORMAT( 2X, 'The collected benchmark result is a tuple ', $ '( x, y ) where x is the mean',/, $ 2X, 'value of the GEMM-Efficiency and y is the mean ', $ 'value of the performance',/, $ 2X, 'of CGEMM in megaflops (see the README file). The ', $ 'benchmark result is',/, $ 2X, 'based on the shortest of', I3,' runs for each ', $ 'problem configuration.' ) 9050 FORMAT( 8X, 'Input parameters.' ) 9060 FORMAT( 8X, A, ' ', 10( A, ' ' ) ) 9070 FORMAT( 8X, A, 1X, 12( I5 ), 2( /, 16X, 12( I5 ) ) ) 9080 FORMAT( 8X, A, ( '(', F6.2, ',', F6.2, ')' ) ) 9090 FORMAT( 8X, 'Test label: ', A ) 9100 FORMAT( 8X, 'Collected result: (', F7.2,',', F9.1,' )' ) 9110 FORMAT( 1X, '**************************************************', $ '****************************' ) * * End of CGBTP1. * END SHAR_EOF fi # end of overwriting check if test -f 'cgbtp2.f' then echo shar: will not over-write existing file "'cgbtp2.f'" else cat << SHAR_EOF > 'cgbtp2.f' SUBROUTINE CGBTP2( TAB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, $ NOUT, MXTAB, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, $ RUNS, ALPHA, BETA, LBL, USRES, MMRES, GBRES ) * .. Scalar Arguments .. INTEGER NOUT, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXTAB, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS COMPLEX ALPHA, BETA * .. Parameters .. INTEGER LST PARAMETER ( LST = 50 ) * .. Array Arguments .. LOGICAL TABSUB( MXSUB ), TAB( MXTAB ) CHARACTER LBL*( LST ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXTRNS ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) REAL USRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ GBRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ) * * * CGBTP2 prints tables showing detailed performance results and * comparisons between the user-supplied and the built-in GEMM-Based * Level 3 BLAS routines. The table results are intended for program * developers and others who are interested in detailed performance * presentations. Performance of the user-supplied and the built-in * GEMM-Based Level 3 BLAS routines are shown. The tables also show * GEMM-Efficiency and GEMM-Ratio. See the README and INSTALL files * for further information. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER D, I, L, NTIM, OP1, OP2, OP3, OP4 REAL MM, GE, GB, GR, US * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. Parameters .. INTEGER MXTOTS, LLN REAL ZERO, HUGE PARAMETER ( MXTOTS = 6, LLN = 256, ZERO = 0.0E+0, $ HUGE = 1.0E+10 ) INTEGER B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, B11, $ E1, E2, E3, E4, E5, E6, E7, E8, E9, E10, E11 PARAMETER ( B1 = 1, B2 = 3, B3 = 5, B4 = 7, B5 = 9, $ B6 = 16, B7 = 23, B8 = 34, B9 = 45, B10 = 56, $ B11 = 66, $ E1 = 2, E2 = 4, E3 = 6, E4 = 8, E5 = 15, $ E6 = 22, E7 = 33, E8 = 44, E9 = 55, E10 = 65, $ E11 = 74 ) * .. Local Arrays .. CHARACTER OUTLN*( LLN ), OUTLN2*( LLN ), OUTLN3*( LLN ) REAL MI( MXTOTS ), MA( MXTOTS ), SU( MXTOTS ) * .. * .. Executable Statements .. * * Print an introduction. * WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9000 ) WRITE( NOUT, FMT = 9010 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9020 ) WRITE( NOUT, FMT = 9030 ) 'SIDE ', ( SIDE( I ), I = 1, NSIDE ) WRITE( NOUT, FMT = 9030 ) 'UPLO ', ( UPLO( I ), I = 1, NUPLO ) WRITE( NOUT, FMT = 9030 ) 'TRANS ', ( TRNS( I ), I = 1, NTRNS ) WRITE( NOUT, FMT = 9030 ) 'DIAG ', ( DIAG( I ), I = 1, NDIAG ) WRITE( NOUT, FMT = 9040 ) 'DIM1 ', ( DIM1( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9040 ) 'DIM2 ', ( DIM2( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9040 ) 'LDA ', ( LDA( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9050 ) 'ALPHA ', ALPHA WRITE( NOUT, FMT = 9050 ) 'BETA ', BETA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9060 ) RUNS WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9070 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9080 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9090 ) LBL WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) * * Print result tables for CSYMM. * IF( TABSUB( 1 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'CSYMM ', $ ' OPTIONS = SIDE,UPLO' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 50, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 10, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 10 CONTINUE NTIM = 0 DO 40, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 30, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 20, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 1, OP1, OP2, 1, 1, D, L ) MM = MMRES( 1, OP1, OP2, 1, 1, D, L ) GB = GBRES( 1, OP1, OP2, 1, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B7:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 20 CONTINUE 30 CONTINUE 40 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 50 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for CHEMM. * IF( TABSUB( 2 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'CHEMM ', $ ' OPTIONS = SIDE,UPLO' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 100, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 60, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 60 CONTINUE NTIM = 0 DO 90, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 80, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 70, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 2, OP1, OP2, 1, 1, D, L ) MM = MMRES( 2, OP1, OP2, 1, 1, D, L ) GB = GBRES( 2, OP1, OP2, 1, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B7:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 70 CONTINUE 80 CONTINUE 90 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 100 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for CSYRK. * IF( TABSUB( 3 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'CSYRK ', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 150, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 110, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 110 CONTINUE NTIM = 0 DO 140, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 130, OP3 = 1, NTRNS IF( .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 120, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 3, 1, OP2, OP3, 1, D, L ) MM = MMRES( 3, 1, OP2, OP3, 1, D, L ) GB = GBRES( 3, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 120 CONTINUE END IF 130 CONTINUE 140 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 150 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for CHERK. * IF( TABSUB( 4 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'CHERK ', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 200, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 160, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 160 CONTINUE NTIM = 0 DO 190, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 180, OP3 = 1, NTRNS IF( .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 170, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 4, 1, OP2, OP3, 1, D, L ) MM = MMRES( 4, 1, OP2, OP3, 1, D, L ) GB = GBRES( 4, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 170 CONTINUE END IF 180 CONTINUE 190 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 200 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for CSYR2K. * IF( TABSUB( 5 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'CSYR2K', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 250, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 210, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 210 CONTINUE NTIM = 0 DO 240, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 230, OP3 = 1, NTRNS IF( .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 220, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 5, 1, OP2, OP3, 1, D, L ) MM = MMRES( 5, 1, OP2, OP3, 1, D, L ) GB = GBRES( 5, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 220 CONTINUE END IF 230 CONTINUE 240 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 250 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for CHER2K. * IF( TABSUB( 6 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'CHER2K', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 300, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 260, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 260 CONTINUE NTIM = 0 DO 290, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 280, OP3 = 1, NTRNS IF( .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 270, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 6, 1, OP2, OP3, 1, D, L ) MM = MMRES( 6, 1, OP2, OP3, 1, D, L ) GB = GBRES( 6, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 270 CONTINUE END IF 280 CONTINUE 290 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 300 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for CTRMM. * IF( TABSUB( 7 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'CTRMM ', $ 'OPTIONS = SIDE,UPLO,TRANS,DIAG' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 370, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 310, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 310 CONTINUE NTIM = 0 DO 360, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 350, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) DO 340, OP3 = 1, NTRNS WRITE( OUTLN( B3:E3 ), FMT = 9130 ) TRNS( OP3 ) DO 330, OP4 = 1, NDIAG WRITE( OUTLN( B4:E4 ), FMT = 9130 ) DIAG( OP4 ) DO 320, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 7, OP1, OP2, OP3, OP4, D, L ) MM = MMRES( 7, OP1, OP2, OP3, OP4, D, L ) GB = GBRES( 7, OP1, OP2, OP3, OP4, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 320 CONTINUE 330 CONTINUE 340 CONTINUE 350 CONTINUE 360 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 370 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for CTRSM. * IF( TABSUB( 8 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'CTRSM ', $ 'OPTIONS = SIDE,UPLO,TRANS,DIAG' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 440, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 380, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 380 CONTINUE NTIM = 0 DO 430, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 420, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) DO 410, OP3 = 1, NTRNS WRITE( OUTLN( B3:E3 ), FMT = 9130 ) TRNS( OP3 ) DO 400, OP4 = 1, NDIAG WRITE( OUTLN( B4:E4 ), FMT = 9130 ) DIAG( OP4 ) DO 390, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 8, OP1, OP2, OP3, OP4, D, L ) MM = MMRES( 8, OP1, OP2, OP3, OP4, D, L ) GB = GBRES( 8, OP1, OP2, OP3, OP4, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 390 CONTINUE 400 CONTINUE 410 CONTINUE 420 CONTINUE 430 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 440 CONTINUE END IF WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9260 ) * RETURN * * Print formats. * 9000 FORMAT( 17X, '**** GEMM-Based Level 3 BLAS Benchmark ****' ) 9010 FORMAT( 33X, 'Table Results',/, $ 33X, ' Complex ' ) 9020 FORMAT( 8X, 'Input parameters.' ) 9030 FORMAT( 8X, A, 3X, 10( A, ' ' ) ) 9040 FORMAT( 8X, A, 1X, 12( I5 ), 2( /, 16X, 12( I5 ) ) ) 9050 FORMAT( 8X, A, ( '(', F6.2, ',', F6.2, ')' ) ) 9060 FORMAT( 8X, 'Results are based on the shortest execution time ', $ 'of ', I2, ' runs for ',/, $ 8X, 'each problem configuration.' ) 9070 FORMAT( 27X, 'Performance of a user-supplied',/, $ 27X, 'Level 3 BLAS routine (megaflops).',/, $ 8X, 'GEMM-Efficiency = -------------------------------', $ '----',/, $ 27X, 'Performance of the user-supplied',/, $ 27X, 'CGEMM routine (megaflops).' ) 9080 FORMAT( 22X, 'Performance for the internal GEMM-Based',/, $ 22X, 'Level 3 BLAS routine Cxxxx (megaflops).',/, $ 8X, 'GEMM-Ratio = ------------------------------------', $ '-----',/, $ 22X, 'Performance of the user-supplied',/, $ 22X, 'Level 3 BLAS routine Cxxxx (megaflops).' ) 9090 FORMAT( 8X, 'Test label: ', A ) 9100 FORMAT( 2X, A, 38X, A ) 9110 FORMAT( 31X, 'GEMM- User-', /, $ 29X,'Based lib suppl lib CGEMM GEMM- GEMM-', /, $ 2X, 'OPTIONS ', A,' ', A,' ', $ 'Mflops Mflops Mflops Eff. Ratio', /, $ 2X, '==================================================', $ '=========================' ) 9120 FORMAT( 2X, '( LDA = ', I4, ' )' ) 9130 FORMAT( A ) 9140 FORMAT( I7 ) 9150 FORMAT( F11.1 ) 9160 FORMAT( ' ' ) 9170 FORMAT( F10.2 ) 9180 FORMAT( ' ' ) 9190 FORMAT( F9.2 ) 9200 FORMAT( ' ' ) 9210 FORMAT( 2X, A ) 9220 FORMAT( 2X, '--------------------------------------------------', $ '-------------------------' ) 9230 FORMAT( 'Min ', 15X ) 9240 FORMAT( 'Max ', 15X ) 9250 FORMAT( 'Mean ', 15X ) 9260 FORMAT( 1X, '**************************************************', $ '****************************' ) * * End of CGBTP2. * END SHAR_EOF fi # end of overwriting check if test -f 'cmark01.in' then echo shar: will not over-write existing file "'cmark01.in'" else cat << SHAR_EOF > 'cmark01.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * CMARK01 * * * We propose two standard test suits for the collected benchmark * result, CMARK01 and CMARK02 (see the files 'cmark01.in' and * 'cmark02.in'). These tests are designed to show performance of the * user-supplied Level 3 library for problem sizes that are likely to * often be requested by a calling routine. This imply problems that * presumably constitute a large part of computations in routines which * use the Level 3 BLAS as their major computational kernels. LAPACK * implements blocked algorithms which are based on calls to the Level 3 * BLAS. The problems in the two tests are similar. However, some of the * matrix dimensions are larger in CMARK02 than in CMARK01. This * corresponds to larger matrix blocks in the calling routine. The tests * are expected to match various target machines differently. * Performance results may depend strongly on sizes of different storage * units in the memory hierarchy. The size of the cache memory, for * instance, may be decisive. For this reason, we propose two standard * tests instead of one. * * *** Label of this test *** LBL CMARK01 *** Benchmark results to be presented *** TAB 1 3 4 5 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 3 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T C DIAG N U DIM1 16 32 512 512 512 DIM2 512 512 16 32 512 LDA 512 530 *** Routines to be timed *** CSYMM T CHEMM T CSYRK T CHERK T CSYR2K T CHER2K T CTRMM T CTRSM T SHAR_EOF fi # end of overwriting check if test -f 'cmark02.in' then echo shar: will not over-write existing file "'cmark02.in'" else cat << SHAR_EOF > 'cmark02.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * CMARK02 * * * We propose two standard test suits for the collected benchmark * result, CMARK01 and CMARK02 (see the files 'cmark01.in' and * 'cmark02.in'). These tests are designed to show performance of the * user-supplied Level 3 library for problem sizes that are likely to * often be requested by a calling routine. This imply problems that * presumably constitute a large part of computations in routines which * use the Level 3 BLAS as their major computational kernels. LAPACK * implements blocked algorithms which are based on calls to the Level 3 * BLAS. The problems in the two tests are similar. However, some of the * matrix dimensions are larger in CMARK02 than in CMARK01. This * corresponds to larger matrix blocks in the calling routine. The tests * are expected to match various target machines differently. * Performance results may depend strongly on sizes of different storage * units in the memory hierarchy. The size of the cache memory, for * instance, may be decisive. For this reason, we propose two standard * tests instead of one. * * *** Label of this test *** LBL CMARK02 *** Benchmark results to be presented *** TAB 1 3 4 5 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 3 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T C DIAG N U DIM1 64 128 512 512 512 DIM2 512 512 64 128 512 LDA 512 530 *** Routines to be timed *** CSYMM T CHEMM T CSYRK T CHERK T CSYR2K T CHER2K T CTRMM T CTRSM T SHAR_EOF fi # end of overwriting check if test -f 'csbpm.f' then echo shar: will not over-write existing file "'csbpm.f'" else cat << SHAR_EOF > 'csbpm.f' PROGRAM CSBPM * * CSBPM re-writes GEMM-Based Level 3 BLAS source files replacing lines * containing old PARAMETER statements for user specified parameters, * with lines containing new PARAMETER statements given in an input * file. The user can conveniently assign new values to the PARAMETER * statements in the input file, and then run CSBPM to distribute these * values to the GEMM-based routines. An input file consists of three * different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file (see the input file * 'sgpm.in'). Read the file INSTALL for further instructions. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, IB, IE, JB, JE, KB, KE, LB, LE, NAM, NXTLN LOGICAL PMEOF * .. External Functions .. LOGICAL LNCMP, GETWRD INTEGER EOLN EXTERNAL LNCMP, GETWRD, EOLN * .. Parameters .. INTEGER NPM, NGB, NTMP, NERR PARAMETER ( NPM = 5, NERR = 6, NGB = 10, NTMP = 12 ) INTEGER NLNS, LLN PARAMETER ( NLNS = 14, LLN = 256 ) CHARACTER TMPNAM*( LLN ) PARAMETER ( TMPNAM = 'tmpgb.tmp' ) * .. Local Arrays .. CHARACTER PMLN*( LLN ), GBLN*( LLN ), GBNAM*( LLN ), $ STRS( NLNS, 2 )*( LLN ), BNAM( NLNS )*( LLN ) CHARACTER PMLNA( LLN ), GBLNA( LLN ), GBNAMA( LLN ), $ STRSA( LLN, NLNS, 2 ), BNAMA( LLN, NLNS ) EQUIVALENCE ( PMLN, PMLNA ), ( GBLN, GBLNA ), $ ( GBNAM, GBNAMA ), ( STRS, STRSA ), $ ( BNAM, BNAMA ) * .. Data statements .. DATA BNAM/ $'cgb02.f' ,'cgb03.f' ,'cgb04.f' ,'cgb05.f' , $'cgb06.f' ,'cgb07.f' ,'cgb08.f' ,'cgb09.f' , $'cgb90.f' ,' ',' ',' ', $'cgb91.f' ,' '/ DATA STRS/ $'csymm.f' ,'chemm.f' ,'csyrk.f' ,'cherk.f' , $'csyr2k.f' ,'cher2k.f' ,'ctrmm.f' ,'ctrsm.f' , $'cbigp.f' ,' ',' ',' ', $'ccld.f' ,' ', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( CIP41 = $$ , CIP42 = $$ ,', $'$ CIP51 = $$ , CIP52 = $$ ,', $'$ CIP81 = $$ , CIP82 = $$ , CIP83 = $$ ,', $'$ CIP91 = $$ , CIP92 = $$ , CIP93 = $$ )', $'PARAMETER ( LNSZ = $$ , NPRT = $$ , PRTSZ = $$ ,', $'$ LOLIM = $$ , CP = $$ )' / * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. * 10 READ( NPM, FMT = 9000, END = 110 ) GBNAM IF( .NOT.GETWRD( GBNAMA, LLN, IB, IE ).OR. $ ( GBNAM( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * Check if the first word on the line is the name of a file that is * due to be changed. * 20 NAM = -1 PMEOF = .FALSE. DO 30, I = 1, NLNS IF( GBNAM( IB:IE ).EQ.STRS( I, 1 ) )THEN NAM = I IF( .NOT.GETWRD( BNAMA( 1, NAM ), LLN, LB, LE ) )THEN WRITE( NERR, FMT = * ) $ 'Benchmark routine name corresponding to ', $ GBNAM( IB:IE ), ' is missing in CSBPM.' STOP END IF END IF 30 CONTINUE IF( NAM.EQ.-1 )THEN WRITE( NERR, FMT = * )'Unknown routine name: ', GBNAM( IB:IE ) STOP END IF * * Read the next non-blank/non-comment line from the input parameter * file. * 40 READ( NPM, FMT = 9000, END = 110 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 40 END IF * * Copy each line of the GEMM-Based file, except for the lines that * are due to be changed, to the temporary file TMPNAM. Copy the * lines that should be changed from the input parameter file. Check * that the lines in the parameter file are correct compared to STRS. * NXTLN = NAM IF( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN OPEN( NGB, FILE = BNAM( NAM )( LB:LE ), STATUS = 'OLD' ) OPEN( NTMP, FILE = TMPNAM, STATUS = 'NEW' ) 50 READ( NGB, FMT = 9000, END = 80 ) GBLN IF( LNCMP( GBLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN WRITE( NTMP, FMT = 9010 ) PMLN( 1:EOLN( PMLNA, LLN ) ) 60 READ( NPM, FMT = 9000, END = 70 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 60 END IF IF( .NOT.GETWRD( STRSA( 1, NXTLN+1, 1 ), LLN, KB, KE ).AND. $ ( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN+1, 2 ), LLN ) ) $ )THEN NXTLN = NXTLN + 1 END IF ELSE WRITE( NTMP, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) END IF GO TO 50 70 PMEOF = .TRUE. GO TO 50 80 CLOSE( NGB, STATUS = 'DELETE' ) CLOSE( NTMP, STATUS = 'KEEP' ) ELSE WRITE( NERR, FMT = * )'Error in parameter file: ' WRITE( NERR, FMT = * ) PMLN STOP END IF * * Write back the temporary file TMPNAM to the GEMM-Based file and * remove the temporary file. * OPEN( NTMP, FILE = TMPNAM, STATUS = 'OLD' ) OPEN( NGB, FILE = BNAM( NAM )( LB:LE ), STATUS = 'NEW' ) 90 READ( NTMP, FMT = 9000, END = 100 ) GBLN WRITE( NGB, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) GO TO 90 100 CONTINUE CLOSE( NTMP, STATUS = 'DELETE' ) CLOSE( NGB, STATUS = 'KEEP' ) GBNAM = PMLN IB = JB IE = JE * IF( .NOT.PMEOF )THEN GO TO 20 END IF 110 CONTINUE * STOP * 9000 FORMAT( A ) 9010 FORMAT( A ) * * End of SSGPM. * END LOGICAL FUNCTION LNCMP( LN1, LEN1, LN2, LEN2 ) * .. Scalar Arguments .. INTEGER LEN1, LEN2 * .. Array Arguments .. CHARACTER LN1( LEN1 ), LN2( LEN2 ) * * Compare the character strings LN1 and LN2. Return .TRUE. if the * strings are identical except from wild cards ($$) corresponding * to positive integers and except from a different number of * consecutive blanks between tokens. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER I, J LOGICAL MATCH * .. Intrinsic Functions .. INTRINSIC LGE, LLE LOGICAL LGE, LLE * .. * .. Executable Statements .. * * Find the beginning of the next tokens in LN1 and LN2. * I = 1 J = 1 10 IF( ( LN1( I ).EQ.' ' ).AND.( I.LT.LEN1 ) )THEN I = I + 1 GO TO 10 END IF 20 IF( ( LN2( J ).EQ.' ' ).AND.( J.LT.LEN2 ) )THEN J = J + 1 GO TO 20 END IF * * Compare the tokens. * IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.LT.LEN1 ).AND. $ ( J.LT.LEN2 ) )THEN I = I + 1 J = J + 1 GO TO 10 ELSE IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.EQ.LEN1 ).AND. $ ( J.EQ.LEN2 ) )THEN LNCMP = .TRUE. RETURN ELSE IF( ( I.EQ.LEN1 ).AND.( J.EQ.LEN2 ) )THEN LNCMP = .FALSE. RETURN ELSE IF( LN1( I ).EQ.'$' )THEN IF( I.LT.LEN1-1 )THEN IF( LN1( I+1 ).EQ.'$' )THEN I = I + 2 MATCH = .FALSE. 30 IF( ( LGE( LN2( J ), '0' ).AND.LLE( LN2( J ), '9' ) ) $ .AND.( J.LT.LEN2 ) )THEN J = J + 1 MATCH = .TRUE. GO TO 30 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 ELSE IF( LN2( J ).EQ.'$' )THEN IF( J.LT.LEN2-1 )THEN IF( LN2( J+1 ).EQ.'$' )THEN J = J + 2 MATCH = .FALSE. 40 IF( ( LGE( LN1( I ), '0' ).AND.LLE( LN1( I ), '9' ) ) $ .AND.( I.LT.LEN1 ) )THEN I = I + 1 MATCH = .TRUE. GO TO 40 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 END IF * LNCMP = .FALSE. RETURN * * End of LNCMP. * END SHAR_EOF fi # end of overwriting check if test -f 'eoln.f' then echo shar: will not over-write existing file "'eoln.f'" else cat << SHAR_EOF > 'eoln.f' INTEGER FUNCTION EOLN( LN, LLN ) * .. Scalar Arguments .. INTEGER LLN * .. Array Arguments .. CHARACTER LN( LLN ) * * Return the index of the last non-blank character in the last word * (token) of LN. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER IE * .. * .. Executable Statements .. * * Find the end of the last word (token) of LN. * IE = LLN 10 IF( ( LN( IE ).EQ.' ' ).AND.( IE.GE.1 ) )THEN IE = IE - 1 GO TO 10 END IF EOLN = IE * RETURN * * End of EOLN. * END SHAR_EOF fi # end of overwriting check if test -f 'example.in' then echo shar: will not over-write existing file "'example.in'" else cat << SHAR_EOF > 'example.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * Example input file * Complex * * * Benchmark results to be presented (parameter TAB): * * 1 The collected benchmark result. * * 2 Performance of the built-in GEMM-Based Level 3 BLAS library * in megaflops. * * 3 Performance of the user-supplied Level 3 BLAS library in * megaflops. * * 4 Performance of the user-supplied CGEMM routine in megaflops. * Problem configurations for CGEMM are chosen to 'correspond' to * those in 2 and 3 for timing purposes, see section 3. * * 5 GEMM-Efficiency of the user-supplied Level 3 routines. * * Performance of a user-supplied * Level 3 BLAS routine (megaflops). * GEMM-Efficiency = ----------------------------------- * Performance of the user-supplied * CGEMM routine (megaflops). * * 6 GEMM-Ratio. * * Performance of the internal GEMM-Based * Level 3 BLAS routine Cxxxx (megaflops). * GEMM-Ratio = ----------------------------------------- * Performance of the user-supplied * Level 3 BLAS routine Cxxxx (megaflops). * *** Label of this test *** LBL Example 1, complex. *** Benchmark results to be presented *** TAB 1 2 3 4 5 6 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 2 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T C DIAG N DIM1 32 64 256 256 DIM2 256 256 32 64 LDA 256 *** Routines to be timed *** CSYMM T CHEMM T CSYRK T CHERK T CSYR2K T CHER2K T CTRMM T CTRSM T SHAR_EOF fi # end of overwriting check if test -f 'getwrd.f' then echo shar: will not over-write existing file "'getwrd.f'" else cat << SHAR_EOF > 'getwrd.f' LOGICAL FUNCTION GETWRD( LN, LLN, IB, IE ) * .. Scalar Arguments .. INTEGER LLN, IB, IE * .. Array Arguments .. CHARACTER LN( LLN ) * * Read the first non-blank word from the character string LN. Set * the indices IB and IE to the beginning and end of the word, * respectively. Return .TRUE. if a word was found and .FALSE. if no * word was found. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * .. * .. Executable Statements .. * * Find the beginning of the word. * IB = 1 10 IF( ( LN( IB ).EQ.' ' ).AND.( IB.LT.LLN ) )THEN IB = IB + 1 GO TO 10 END IF * * Find the end of the word. * IE = IB 20 IF( IE.LT.LLN )THEN IF( LN( IE+1 ).NE.' ' )THEN IE = IE + 1 GO TO 20 END IF END IF * * Check if any word was found. * IF( LN( IB ).NE.' ' )THEN GETWRD = .TRUE. ELSE GETWRD = .FALSE. END IF * RETURN * * End of GETWRD. * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'newcgpm.in' then echo shar: will not over-write existing file "'newcgpm.in'" else cat << SHAR_EOF > 'newcgpm.in' * * Example of an input file for the program CSGPM containing user * specified parameters. * * The enclosed program CSGPM re-writes GEMM-Based Level 3 BLAS source * files replacing lines containing old PARAMETER statements for user * specified parameters, with lines containing new PARAMETER statements * given in an input file. The user can conveniently assign new values * to the PARAMETER statements in the input file, and then run CSGPM to * distribute these values to the GEMM-based routines. An input file * consists of three different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file. Read the file * INSTALL for further instructions on how to use this file. * csymm.f PARAMETER ( RCB = 128, CB = 64 ) chemm.f PARAMETER ( RCB = 128, CB = 64 ) csyr2k.f PARAMETER ( RCB = 128, CB = 64 ) cher2k.f PARAMETER ( RCB = 128, CB = 64 ) csyrk.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) cherk.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) ctrmm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) ctrsm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) cbigp.f PARAMETER ( CIP41 = 4, CIP42 = 3, $ CIP51 = 4, CIP52 = 3, $ CIP81 = 4, CIP82 = 3, CIP83 = 4, $ CIP91 = 4, CIP92 = 3, CIP93 = 4 ) ccld.f PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, CP = 8 ) SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'DBENCH' then mkdir 'DBENCH' fi cd 'DBENCH' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### GEMM-Based Level 3 BLAS Benchmark #################################### # # The following libraries are specified, a user specified level 3 BLAS # library to be timed (LIB3B), a library with underlying BLAS routines # (LIB12B) where the underlying BLAS routine DGEMM may be specified # separately, and the library with the timing functions SECOND and # DSECND (DSEC). # LIB3B = $(ULIB) DGEMM = $(UULIB) LIB12B = $(UULIB) DSEC = $(UTMG) # # LIB specifies the order in which the libraries are linked with the # benchmark programs. Notice that the built-in GEMM-based routines # will be linked the first DGEMM, level 1 and 2 BLAS routines found # as underlying routines. Change the order in which the libraries are # linked as desired. # LIB = $(DSEC) $(LIB3B) $(DGEMM) $(LIB12B) # ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # DBMFLG : the GEMM-based performance benchmark programs # DPRFLG : routines that print the output results # DGBFLG : the built-in GEMM-based level 3 BLAS routines # DAXFLG : GEMM-based specific auxiliary routines # AXOPT : other auxiliary routines # DBMFLG = $(GBBOPT) DPRFLG = $(AXOPT) DGBFLG = $(GBOPT) DAXFLG = $(GBOPT) AXFLG = $(AXOPT) # ######################################################################## DTIMS = dgbtim.f DTIM = dgbtim.o DBMS = dgbt01.f dgbt02.f DBM = dgbt01.o dgbt02.o DPRS = dgbtp1.f dgbtp2.f DPR = dgbtp1.o dgbtp2.o DGBS = dgb02.f dgb04.f dgb06.f dgb08.f dgb09.f DGB = dgb02.o dgb04.o dgb06.o dgb08.o dgb09.o DAUXS = dgb90.f dgb91.f DAUX = dgb90.o dgb91.o AUXS = lsame.f xerbla.f AUX = lsame.o xerbla.o DPRMS = dsbpm.f DPRM = dsbpm.o AUXS2 = getwrd.f eoln.f AUX2 = getwrd.o eoln.o OBJ1 = $(DTIM) $(DBM) $(DGB) $(DAUX) $(AUX) $(AUX2) $(DPR) OBJ2 = $(DPRM) $(AUX2) ######################################################################## all: dgbtim dsbpm dgbtim: $(OBJ1) $(LOADER) $(LOADOPT) -o dgbtim $(OBJ1) $(LIB) dsbpm: $(OBJ2) $(LOADER) $(LOADOPT) -o dsbpm $(OBJ2) $(DTIM): $(DTIMS) $(FORTRAN) -c $(DBMFLG) $(DTIMS) $(DBM): $(DBMS) $(FORTRAN) -c $(DBMFLG) $(DBMS) $(DPR): $(DPRS) $(FORTRAN) -c $(DPRFLG) $(DPRS) $(DGB): $(DGBS) $(FORTRAN) -c $(DGBFLG) $(DGBS) $(DAUX): $(DAUXS) $(FORTRAN) -c $(DAXFLG) $(DAUXS) $(AUX): $(AUXS) $(FORTRAN) -c $(AXFLG) $(AUXS) $(DPRM): $(DPRMS) $(FORTRAN) -c $(AXFLG) $(DPRMS) $(AUX2): $(AUXS2) $(FORTRAN) -c $(AXFLG) $(AUXS2) clean: rm -f *.o dgbtim dsbpm SHAR_EOF fi # end of overwriting check if test -f 'dgb02.f' then echo shar: will not over-write existing file "'dgb02.f'" else cat << SHAR_EOF > 'dgb02.f' SUBROUTINE DGB02( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGB02 (DSYMM) performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is a symmetric matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the symmetric matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the symmetric matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * symmetric matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * symmetric matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DCOPY * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. User specified parameters for DGB02 .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. DOUBLE PRECISION T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGB02 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL DGEMM ( 'N', 'N', M, N, 0, ZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by DCOPY is CB. * DO 30, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 20, J = JJ+1, II+ISEC-1 CALL DCOPY ( MIN( JSEC, J-JJ ), A( JJ, J ), 1, $ T1( J-II+1, JJ-II+1 ), RCB ) 20 CONTINUE 30 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, DGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL DGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 80, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 50, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 50 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by DCOPY is CB. * DO 70, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 60, J = II, JJ+JSEC-2 CALL DCOPY ( MIN( JSEC, JJ+JSEC-1-J ), $ A( MAX( JJ, J+1 ), J ), 1, $ T1( J-II+1, MAX( JJ-II+1, J-II+2 ) ), RCB ) 60 CONTINUE 70 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, DGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL DGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF 80 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 120, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 90, J = JJ, JJ+JSEC-1 CALL DCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 90 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by DCOPY is CB. * DO 110, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 100, I = II+1, JJ+JSEC-1 CALL DCOPY ( MIN( ISEC, I-II ), A( II, I ), 1, $ T1( I-JJ+1, II-JJ+1 ), RCB ) 100 CONTINUE 110 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, DGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL DGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF 120 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 160, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL DCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 130 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by DCOPY is CB. * DO 150, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 140, I = JJ, II+ISEC-2 CALL DCOPY ( MIN( ISEC, II+ISEC-1-I ), $ A( MAX( II, I+1 ), I ), 1, $ T1( I-JJ+1, MAX( II-JJ+1, I-JJ+2 ) ), RCB ) 140 CONTINUE 150 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, DGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL DGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 160 CONTINUE END IF END IF * RETURN * * End of DGB02. * END SHAR_EOF fi # end of overwriting check if test -f 'dgb04.f' then echo shar: will not over-write existing file "'dgb04.f'" else cat << SHAR_EOF > 'dgb04.f' SUBROUTINE DGB04( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGB04 (DSYRK) performs one of the symmetric rank k operations * * C := alpha*A*A' + beta*C, * * or * * C := alpha*A'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A is an n by k matrix in the first case and a k by n matrix * in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. * * TRANS = 'T' or 't' C := alpha*A'*A + beta*C. * * TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number * of rows of the matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK DOUBLE PRECISION DELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME, DGB90, DGB91 EXTERNAL LSAME, DGB90, DGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DGEMV, DSYR, DCOPY, DSCAL * .. Parameters .. DOUBLE PRECISION ONE, ZERO INTEGER DIP41, DIP42 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ DIP41 = 41, DIP42 = 42 ) * .. User specified parameters for DGB04 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) * .. Local Arrays .. DOUBLE PRECISION T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGB04 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL DSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL DSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Upper, Notr. * SMALLN = .NOT.DGB90( DIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.DGB90( DIP42 , N, K ) DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 40, L = 1, K CALL DSYR ( 'U', ISEC, ALPHA, A( II, L ), 1, $ C( II, II ), LDC ) 40 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 50, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 50 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 60, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 60 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having upper * triangular storage format. * DO 70, L = 1, K CALL DSYR ( 'U', ISEC, ALPHA, A( II, L ), 1, $ T2( 1, 1 ), RCB ) 70 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 80, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 80 CONTINUE END IF 90 CONTINUE ELSE DO 130, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 120, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 100, L = LL, LL+LSEC-1 CALL DCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 100 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 110, I = II, II+ISEC-1 CALL DGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 110 CONTINUE DELTA = ONE 120 CONTINUE 130 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Upper, Trans. * SMALLN = .NOT.DGB90( DIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.DGB90( DIP42 , N, K ) DO 220, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 140, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, C( II, I ), 1 ) 140 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 150, L = 1, K CALL DSYR ( 'U', ISEC, ALPHA, A( L, II ), LDA, $ C( II, II ), LDC ) 150 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 160, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 160 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 170, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 170 CONTINUE END IF DO 200, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 180, I = II, II+ISEC-1 CALL DCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 180 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * upper triangular storage format. * DO 190, L = LL, LL+LSEC-1 CALL DSYR ( 'U', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 190 CONTINUE 200 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 210, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 210 CONTINUE END IF 220 CONTINUE ELSE CLDA = DGB91( LDA ) DO 270, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 260, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 230, I = II, II+ISEC-1 CALL DCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 230 CONTINUE ELSE DO 240, L = LL, LL+LSEC-1 CALL DCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 240 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 250, I = II, II+ISEC-1 CALL DGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 250 CONTINUE DELTA = ONE 260 CONTINUE 270 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Lower, Notr. * SMALLN = .NOT.DGB90( DIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.DGB90( DIP42 , N, K ) DO 340, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 280, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 280 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 290, L = 1, K CALL DSYR ( 'L', ISEC, ALPHA, A( II, L ), 1, $ C( II, II ), LDC ) 290 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 300, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 300 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 310, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having lower * triangular storage format. * DO 320, L = 1, K CALL DSYR ( 'L', ISEC, ALPHA, A( II, L ), 1, $ T2( 1, 1 ), RCB ) 320 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 330, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 330 CONTINUE END IF * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 340 CONTINUE ELSE DO 380, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 370, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 350, L = LL, LL+LSEC-1 CALL DCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 350 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 360, I = II, II+ISEC-1 CALL DGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 360 CONTINUE DELTA = ONE 370 CONTINUE * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 380 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Lower, Trans. * SMALLN = .NOT.DGB90( DIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.DGB90( DIP42 , N, K ) DO 470, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 390, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 400, L = 1, K CALL DSYR ( 'L', ISEC, ALPHA, A( L, II ), LDA, $ C( II, II ), LDC ) 400 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 410, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 410 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 420, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 420 CONTINUE END IF DO 450, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 430, I = II, II+ISEC-1 CALL DCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 430 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * lower triangular storage format. * DO 440, L = LL, LL+LSEC-1 CALL DSYR ( 'L', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 440 CONTINUE 450 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 460, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 460 CONTINUE END IF * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 470 CONTINUE ELSE CLDA = DGB91( LDA ) DO 520, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 510, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 480, I = II, II+ISEC-1 CALL DCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 480 CONTINUE ELSE DO 490, L = LL, LL+LSEC-1 CALL DCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 490 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 500, I = II, II+ISEC-1 CALL DGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 500 CONTINUE DELTA = ONE 510 CONTINUE * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 520 CONTINUE END IF END IF END IF * RETURN * * End of DGB04. * END SHAR_EOF fi # end of overwriting check if test -f 'dgb06.f' then echo shar: will not over-write existing file "'dgb06.f'" else cat << SHAR_EOF > 'dgb06.f' SUBROUTINE DGB06( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGB06 (DSYR2K) performs one of the symmetric rank 2k operations * * C := alpha*A*B' + alpha*B*A' + beta*C, * * or * * C := alpha*A'*B + alpha*B'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A and B are n by k matrices in the first case and k by n * matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + * beta*C. * * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + * beta*C. * * TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number * of rows of the matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993 * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, JJ, JX, JSEC LOGICAL UPPER, NOTR * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DAXPY, DSCAL * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. User specified parameters for DGB06 .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. DOUBLE PRECISION T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGB06 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL DSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL DSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Upper, Notr. * DO 70, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL DGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL DAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by DAXPY is CB. * DO 60, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 50, I = JJ, II+ISEC-1 CALL DAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 50 CONTINUE 60 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, BETA, $ C( 1, II ), LDC ) CALL DGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ONE, $ C( 1, II ), LDC ) END IF 70 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Upper, Trans. * DO 120, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A'*B, general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL DGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 80, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, C( II, I ), 1 ) 80 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 90, I = II, II+ISEC-1 CALL DAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 90 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by DAXPY is CB. * DO 110, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 100, I = JJ, II+ISEC-1 CALL DAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 100 CONTINUE 110 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, BETA, $ C( 1, II ), LDC ) CALL DGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( 1, II ), LDA, ONE, $ C( 1, II ), LDC ) END IF 120 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Lower, Notr. * DO 170, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL DGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 130, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 130 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 140, I = II, II+ISEC-1 CALL DAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 140 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by DAXPY is CB. * DO 160, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 150, I = II, JJ+JSEC-1 CALL DAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 150 CONTINUE 160 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL DGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ B( II+ISEC, 1 ), LDB, A( II, 1 ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 170 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Lower, Trans. * DO 220, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL DGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 180, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 180 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 190, I = II, II+ISEC-1 CALL DAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 190 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by DAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 CALL DAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 200 CONTINUE 210 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL DGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ B( 1, II+ISEC ), LDB, A( 1, II ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 220 CONTINUE END IF END IF * RETURN * * End of DGB06. * END SHAR_EOF fi # end of overwriting check if test -f 'dgb08.f' then echo shar: will not over-write existing file "'dgb08.f'" else cat << SHAR_EOF > 'dgb08.f' SUBROUTINE DGB08( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGB08 (DTRMM) performs one of the matrix-matrix operations * * C := alpha*op( A )*C, or C := alpha*C*op( A ), * * where alpha is a scalar, C is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies C from * the left or right as follows: * * SIDE = 'L' or 'l' C := alpha*op( A )*C. * * SIDE = 'R' or 'r' C := alpha*C*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, and on exit is overwritten by the * transformed matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOUNIT, CLDC, SMALLN, $ TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC DOUBLE PRECISION GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD * .. External Functions .. LOGICAL LSAME, DGB90, DGB91 EXTERNAL LSAME, DGB90, DGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DGEMV, DTRMV, DCOPY * .. Parameters .. DOUBLE PRECISION ZERO, ONE INTEGER DIP81, DIP82, DIP83 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ DIP81 = 81, DIP82 = 82, DIP83 = 83 ) * .. User specified parameters for DGB08 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) DOUBLE PRECISION T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGB08 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL DGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*C. Left, Upper, No transpose. * SMALLN = .NOT.DGB90( DIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.DGB90( DIP82, M, N ) DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 10, J = 1, N CALL DTRMV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * C := T3*C, triangular matrix multiply involving * a upper triangular diagonal block of A stored * in T3. * DO 30, J = 1, N CALL DTRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE DELTA = ALPHA CLDC = DGB91( LDC ) DO 110, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in DGEMV that appears if the second * dimension (tsec) is zero. * DO 80, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 110 CONTINUE END IF ELSE * * Form C := alpha*A'*C. Left, Upper, Transpose. * SMALLN = .NOT.DGB90( DIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.DGB90( DIP82, M, N ) DO 150, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'T', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 120, J = 1, N CALL DTRMV ( 'U', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A', the transpose of a upper unit or * non-unit triangular diagonal block of A is * copied to the lower triangular part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( I-II+1, 1 ), RCB ) 130 CONTINUE * * C := T3*C, triangular matrix multiply involving * the transpose of a upper triangular diagonal * block of A stored in T3. * DO 140, J = 1, N CALL DTRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 150 CONTINUE ELSE DELTA = ALPHA CLDC = DGB91( LDC ) DO 210, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) DO 200, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 160, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 160 CONTINUE ELSE DO 170, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 170 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 180, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( I, I ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( II, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 180 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 190, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 190 CONTINUE 200 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 210 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*C. Left, Lower, No transpose. * SMALLN = .NOT.DGB90( DIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.DGB90( DIP82, M, N ) DO 250, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 220, J = 1, N CALL DTRMV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 220 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. * DO 230, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 230 CONTINUE * * C := T3*C, triangular matrix multiply involving * a lower triangular diagonal block of A stored * in T3. * DO 240, J = 1, N CALL DTRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 240 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 250 CONTINUE ELSE DELTA = ALPHA CLDC = DGB91( LDC ) DO 320, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 260, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 260 CONTINUE DO 310, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 270, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 280 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in DGEMV that appears if the second * dimension (tsec) is zero. * DO 290, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 290 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 300, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 300 CONTINUE 310 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 320 CONTINUE END IF ELSE * * Form C := alpha*A'*C. Left, Lower, Transpose. * SMALLN = .NOT.DGB90( DIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.DGB90( DIP82, M, N ) DO 360, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'T', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 330, J = 1, N CALL DTRMV ( 'L', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 330 CONTINUE ELSE * * T3 := A', the transpose of a lower unit or * non-unit triangular diagonal block of A is * copied to the upper triangular part of T3. * DO 340, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1, I-II+1+OFFD ), RCB ) 340 CONTINUE * * C := alpha*T3*C, triangular matrix multiply * involving the transpose of a lower triangular * diagonal block of A stored in T3. * DO 350, J = 1, N CALL DTRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 350 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 360 CONTINUE ELSE DELTA = ALPHA CLDC = DGB91( LDC ) DO 420, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 DO 410, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 370, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 370 CONTINUE ELSE DO 380, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 380 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 390, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( I, I ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, A( I+TIJ, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 390 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 400, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 400 CONTINUE 410 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 420 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*C*A. Right, Upper, No transpose. * TINYM = .NOT.DGB90( DIP83, M, N ) IF( TINYM )THEN DO 440, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 430, I = 1, M CALL DTRMV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 430 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 440 CONTINUE ELSE DELTA = ALPHA DO 480, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) DO 470, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 450, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 450 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 460, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 480 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Upper, Transpose. * TINYM = .NOT.DGB90( DIP83, M, N ) IF( TINYM )THEN DO 500, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'T', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A', triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 490, I = 1, M CALL DTRMV ( 'U', 'N', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 500 CONTINUE ELSE DELTA = ALPHA DO 550, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 510, J = JJ+OFFD, JJ+JSEC-1 CALL DCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 510 CONTINUE DO 540, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 520, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 520 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 530, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 530 CONTINUE 540 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 550 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*C*A. Right, Lower, No transpose. * TINYM = .NOT.DGB90( DIP83, M, N ) IF( TINYM )THEN DO 570, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * lower triangular diagonal block of A. * DO 560, I = 1, M CALL DTRMV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 560 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 570 CONTINUE ELSE DELTA = ALPHA DO 610, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 DO 600, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 580, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 580 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 590, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, C( II, J ), 1 ) 590 CONTINUE 600 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 610 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Lower, Transpose. * TINYM = .NOT.DGB90( DIP83, M, N ) IF( TINYM )THEN DO 630, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'T', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A', triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 620, I = 1, M CALL DTRMV ( 'L', 'N', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 620 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 630 CONTINUE ELSE DELTA = ALPHA DO 680, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 640, J = JJ, JJ+JSEC-1-OFFD CALL DCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 640 CONTINUE DO 670, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 650, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 650 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 660, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 660 CONTINUE 670 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 680 CONTINUE END IF END IF END IF END IF * RETURN * * End of DGB08. * END SHAR_EOF fi # end of overwriting check if test -f 'dgb09.f' then echo shar: will not over-write existing file "'dgb09.f'" else cat << SHAR_EOF > 'dgb09.f' SUBROUTINE DGB09( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGB09 (DTRSM) solves one of the matrix equations * * op( A )*X = alpha*C, or X*op( A ) = alpha*C, * * where alpha is a scalar, X and C are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * The matrix X is overwritten on C. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*C. * * SIDE = 'R' or 'r' X*op( A ) = alpha*C. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the right-hand side matrix C, and on exit is * overwritten by the solution matrix X. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOUNIT, CLDC, SMALLN, $ TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC DOUBLE PRECISION GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD * .. External Functions .. LOGICAL LSAME, DGB90, DGB91 EXTERNAL LSAME, DGB90, DGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DGEMV, DTRSV, DCOPY * .. Parameters .. DOUBLE PRECISION ZERO, ONE INTEGER DIP91, DIP92, DIP93 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ DIP91 = 91, DIP92 = 92, DIP93 = 93 ) * .. User specified parameters for DGB09 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 7, RB = 5, CB = 3 ) DOUBLE PRECISION T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGB09 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL DGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Upper, No transpose. * SMALLN = .NOT.DGB90( DIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.DGB90( DIP92, M, N ) DO 40, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a upper triangular diagonal block of A. The * block of X is overwritten on C. * DO 10, J = 1, N CALL DTRSV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * Solve T3*X = C, triangular system solve * involving a upper triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 30, J = 1, N CALL DTRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF 40 CONTINUE ELSE DELTA = ONE CLDC = DGB91( LDC ) DO 110, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 80, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE 110 CONTINUE END IF ELSE * * Solve A'*X = alpha*C. Left, Upper, Transpose. * SMALLN = .NOT.DGB90( DIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.DGB90( DIP92, M, N ) DO 150, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL DGEMM ( 'T', 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C, triangular system solve * involving the transpose of a upper triangular * diagonal block of A. The block of X is * overwritten on C. * DO 120, J = 1, N CALL DTRSV ( 'U', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A', the transpose of a upper unit or * non-unit triangular diagonal block of A is * copied to the lower triangular part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( I-II+1, 1 ), RCB ) 130 CONTINUE * * Solve T3*X = C, triangular system solve * involving the transpose of a upper triangular * diagonal block of A stored in T3. The block of X * is overwritten on C. * DO 140, J = 1, N CALL DTRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF 150 CONTINUE ELSE DELTA = ONE CLDC = DGB91( LDC ) DO 210, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL DGEMM ( 'T', 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) DO 200, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 160, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 160 CONTINUE ELSE DO 170, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 170 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 180, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/A( I, I ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( II, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 180 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 190, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 190 CONTINUE 200 CONTINUE 210 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Lower, No transpose. * SMALLN = .NOT.DGB90( DIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.DGB90( DIP92, M, N ) DO 250, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL DGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a lower triangular diagonal block of A. The * block of X is overwritten on C. * DO 220, J = 1, N CALL DTRSV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 220 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. The block of X is * overwritten on C. * DO 230, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 230 CONTINUE * * Solve T3*X = C, triangular system solve * involving a lower triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 240, J = 1, N CALL DTRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 240 CONTINUE END IF 250 CONTINUE ELSE DELTA = ONE CLDC = DGB91( LDC ) DO 320, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL DGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 260, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 260 CONTINUE DO 310, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 270, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 280 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 290, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 290 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 300, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 300 CONTINUE 310 CONTINUE 320 CONTINUE END IF ELSE * * Solve A'*X = alpha*C. Left, Lower, Transpose. * SMALLN = .NOT.DGB90( DIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.DGB90( DIP92, M, N ) DO 360, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C, triangular system solve * involving the transpose of a lower triangular * diagonal block of A. The block of X is * overwritten on C. * DO 330, J = 1, N CALL DTRSV ( 'L', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 330 CONTINUE ELSE * * T3 := A', the transpose of a lower unit or * non-unit triangular diagonal block of A is * copied to the upper triangular part of T3. * DO 340, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1, I-II+1+OFFD ), RCB ) 340 CONTINUE * * Solve T3*X = C, triangular system solve * involving the transpose of a lower triangular * diagonal block of A stored in T3. The block of X * is overwritten on C. * DO 350, J = 1, N CALL DTRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 350 CONTINUE END IF 360 CONTINUE ELSE DELTA = ONE CLDC = DGB91( LDC ) DO 420, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) DO 410, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 370, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 370 CONTINUE ELSE DO 380, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 380 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 390, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/A( I, I ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, A( I+TIJ, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 390 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 400, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 400 CONTINUE 410 CONTINUE 420 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Upper, No transpose. * TINYM = .NOT.DGB90( DIP93, M, N ) IF( TINYM )THEN DO 440, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a upper triangular diagonal block of A. The block * of X is overwritten on C. * DO 430, I = 1, M CALL DTRSV ( 'U', 'T', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 430 CONTINUE 440 CONTINUE ELSE DELTA = ONE DO 490, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 480, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 450, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 450 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 460, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 460 CONTINUE * * C := T1, T1 is copied back to C. * DO 470, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 470 CONTINUE 480 CONTINUE 490 CONTINUE END IF ELSE * * Solve X*A' = alpha*C. Right, Upper, Transpose. * TINYM = .NOT.DGB90( DIP93, M, N ) IF( TINYM )THEN DO 510, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A' = C, triangular system solve involving * the transpose of a upper triangular diagonal block * of A. The block of X is overwritten on C. * DO 500, I = 1, M CALL DTRSV ( 'U', 'N', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 500 CONTINUE 510 CONTINUE ELSE DELTA = ONE DO 570, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 520, J = JJ+OFFD, JJ+JSEC-1 CALL DCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 520 CONTINUE DO 560, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 530, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 530 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 540, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 540 CONTINUE * * C := T1, T1 is copied back to C. * DO 550, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 550 CONTINUE 560 CONTINUE 570 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Lower, No transpose. * TINYM = .NOT.DGB90( DIP93, M, N ) IF( TINYM )THEN DO 590, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a lower triangular diagonal block of A. The block * of X is overwritten on C. * DO 580, I = 1, M CALL DTRSV ( 'L', 'T', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 580 CONTINUE 590 CONTINUE ELSE DELTA = ONE DO 640, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 630, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 600, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 600 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 610, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 610 CONTINUE * * C := T1, T1 is copied back to C. * DO 620, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 620 CONTINUE 630 CONTINUE 640 CONTINUE END IF ELSE * * Solve X*A' = alpha*C. Right, Lower, Transpose. * TINYM = .NOT.DGB90( DIP93, M, N ) IF( TINYM )THEN DO 660, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A' = C, triangular system solve involving * the transpose of a lower triangular diagonal block * of A. The block of X is overwritten on C. * DO 650, I = 1, M CALL DTRSV ( 'L', 'N', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 650 CONTINUE 660 CONTINUE ELSE DELTA = ONE DO 720, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 670, J = JJ, JJ+JSEC-1-OFFD CALL DCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 670 CONTINUE DO 710, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 680, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 680 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 690, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 690 CONTINUE * * C := T1, T1 is copied back to C. * DO 700, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 700 CONTINUE 710 CONTINUE 720 CONTINUE END IF END IF END IF END IF * RETURN * * End of DGB09. * END SHAR_EOF fi # end of overwriting check if test -f 'dgb90.f' then echo shar: will not over-write existing file "'dgb90.f'" else cat << SHAR_EOF > 'dgb90.f' LOGICAL FUNCTION DGB90( IP, DIM1, DIM2 ) * .. Scalar Arguments .. INTEGER IP, DIM1, DIM2 * .. * * Purpose * ======= * * DGB90 determines which of two alternative code sections in a GEMM- * Based Level 3 BLAS routine that will be the fastest for a particular * problem. If the problem is considered large enough DGB90 returns * .TRUE., otherwise .FALSE. is returned. The input parameter IP * specifies the calling routine and a break point for alternative code * sections. The input parameters DIM1 and DIM2 are matrix dimensions. * The returned value is a function of the input parameters and the * performance characteristics of the two alternative code sections. * * In this simple implementation, the returned values are determined by * looking at only one of the two dimensions DIM1 and DIM2. It may be * rewarding to rewrite the logical expressions in DGB90 so that both * dimensions are involved. The returned values should effectively * reflect the performance characteristics of the underlying BLAS * routines. * * * Input * ===== * * IP - INTEGER * On entry, IP specifies which routine and which alternative * code sections that the decision is intended for. * Unchanged on exit. * * DIM1 - INTEGER. * On entry, DIM1 specifies the first dimension in the calling * sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * DIM2 - INTEGER. * On entry, DIM2 specifies the second dimension in the * calling sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. User specified parameters for DGB90 .. INTEGER DIP41, DIP42, DIP81, DIP82, DIP83, $ DIP91, DIP92, DIP93 PARAMETER ( DIP41 = 4, DIP42 = 3, $ DIP81 = 4, DIP82 = 3, DIP83 = 4, $ DIP91 = 4, DIP92 = 3, DIP93 = 4 ) * .. * .. Executable Statements .. IF( IP.EQ.41 )THEN DGB90 = DIM1.GE.DIP41 ELSE IF( IP.EQ.42 )THEN DGB90 = DIM2.GE.DIP42 ELSE IF( IP.EQ.81 )THEN DGB90 = DIM2.GE.DIP81 ELSE IF( IP.EQ.82 )THEN DGB90 = DIM2.GE.DIP82 ELSE IF( IP.EQ.83 )THEN DGB90 = DIM1.GE.DIP83 ELSE IF( IP.EQ.91 )THEN DGB90 = DIM2.GE.DIP91 ELSE IF( IP.EQ.92 )THEN DGB90 = DIM2.GE.DIP92 ELSE IF( IP.EQ.93 )THEN DGB90 = DIM1.GE.DIP93 ELSE DGB90 = .FALSE. END IF * RETURN * * End of DGB90. * END SHAR_EOF fi # end of overwriting check if test -f 'dgb91.f' then echo shar: will not over-write existing file "'dgb91.f'" else cat << SHAR_EOF > 'dgb91.f' LOGICAL FUNCTION DGB91( LD ) * .. Scalar Arguments .. INTEGER LD * .. * * Purpose * ======= * * The size of the leading dimension of a two-dimensional array may * cause severe problems. Often when an array with a 'critical' leading * dimension is referenced, the execution time becomes significantly * longer than expected. This is caused by shortcomings of the memory * system. * * The function DGB91 returns .TRUE. if the leading dimension LD is * critical and .FALSE. if it is not critical. In this implementation * DGB91 is designed to detect critical leading dimensions in an * environment with a multi-way associative cache. Parameters defining * cache characteristics are adjustable to match different machines. * It may be rewarding to rewrite DGB91 for a machine with a different * cache policy. * * The cache lines in a multi-way associative cache are divided among a * number of partitions, each containing the same number of lines. Each * address of main memory is mapped into a particular partition. The * number of lines in a partition equals the associativity. For example, * in a four way associative cache, each partition contain four cache * lines. * * Data are transferred between the cache and main memory according to * an associative mapping scheme. A transfer of a data word from main * memory to cache is accomplished as follows. A unit of data * (data line) in main memory, with the size of a cache line, and * containing several contiguous data words including the referenced * one, is mapped (copied) to a certain partition in the cache memory. * The partition is determined by the location of the element in the * main memory and the associative mapping scheme. A replacement * algorithm makes room for the data line in one of the cache lines in * the selected partition. For example, an LRU-based (Least Recently * Used) replacement algorithm places the data line in the least * recently 'touched' cache line in the selected partition. * * * Input * ===== * * LD - On entry, LD specifies the leading dimension of a * 2-dimensional array. Unchanged on exit. * * * User specified parameters for DGB91 * ================================ * * LNSZ - Size of a cache line in number of bytes. * * NPRT - Number of partitions in the cache memory. * * PRTSZ - The number of cache lines in a partition that can be used * exclusively to hold a local array containing a matrix block * during the execution of a GEMM-Based Level 3 BLAS routine. * The remaining cache lines may be occupied by scalars, * vectors and possibly program code depending on the system. * * LOLIM - Leading dimensions smaller than or equal to LOLIM are not * considered critical. * * DP - Number of bytes in a double-precision word. * * * Local Variables and Parameters * ============================== * * ONEWAY - The maximum number of double precision words that can be * stored in the cache memory if only a single cache line in * each partition may be used. * * UPDIF - The difference between the multiple of LD that is nearest * ONEWAY, or nearest a multiple of ONEWAY, and the nearest * multiple of ONEWAY that is larger than LD. In number of * double precision words. * * MXDIF - If both UPDIF and LD - UPDIF are less than MXDIF, and LD * is greater than LOLIM, then the leading dimension is * considered critical. Otherwise, the leading dimension is * considered not critical. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Variables .. INTEGER UPDIF * .. Intrinsic Functions .. INTRINSIC MIN, MOD * .. User specified parameters for DGB91 .. INTEGER LOLIM, LNSZ, NPRT, PRTSZ, DP PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, DP = 8 ) * .. Parameters .. INTEGER ONEWAY, MXDIF PARAMETER ( ONEWAY = ( LNSZ*NPRT )/DP, $ MXDIF = LNSZ/( DP*PRTSZ ) ) * .. * .. Executable Statements .. * IF( LD.LE.LOLIM )THEN DGB91 = .FALSE. ELSE UPDIF = MOD( ( LD/ONEWAY )*ONEWAY+ONEWAY, LD ) DGB91 = MIN( UPDIF, LD-UPDIF ).LE.MXDIF END IF * RETURN * * End of DGB91. * END SHAR_EOF fi # end of overwriting check if test -f 'dgbt01.f' then echo shar: will not over-write existing file "'dgbt01.f'" else cat << SHAR_EOF > 'dgbt01.f' SUBROUTINE DGBT01( DB3LIB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXDIM, MXLDA, RUNS, RES ) * .. Scalar Arguments .. CHARACTER DB3LIB INTEGER LD, NMAX, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXDIM, MXLDA, RUNS DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXOPT ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) DOUBLE PRECISION A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ), $ RES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, MXDIM, $ MXLDA ) * * * Time all routines except DGEMM in the Level 3 BLAS library specified * by the input parameters. The library is either a user-supplied * Level 3 BLAS library or the GEMM-Based Level 3 BLAS library included * in the benchmark (DGB02, DGB04, DGB06, DGB08, and DGB09). Return the * performance in Mflops for each problem configuration. * * DGBT01 calls a DOUBLE PRECISION function DSECND with no arguments, * which is assumed to return the user time for a process in seconds * from some fixed starting-time. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, J, M, N, K, NOPS, $ D, L, R, OP1, OP2, OP3, OP4 DOUBLE PRECISION TIME, SPEED, TM0, TM1, TM2, TM3, TM4, TM5, TM6, $ TM7, TM8, TM9, TM10, TM11 * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DSECND EXTERNAL LSAME, DSECND * .. External Subroutines .. EXTERNAL DSYMM, DSYRK, DSYR2K, DTRMM, DTRSM, $ DGB02, DGB04, DGB06, DGB08, DGB09 * .. Parameters .. DOUBLE PRECISION ZERO, ONE, SCALE * .. Parameter Values .. PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, SCALE = 1.0D+6 ) * .. * .. Executable Statements .. TM0 = DSECND( ) TM0 = DSECND( ) TM0 = DSECND( ) TM1 = DSECND( ) * * ------ Stop indentation ------ * DO 270, L = 1, NLDA DO 260, OP1 = 1, NSIDE DO 250, OP2 = 1, NUPLO DO 240, OP3 = 1, NTRNS DO 230, OP4 = 1, NDIAG DO 220, D = 1, NDIM * * ------ Continue indentation ------ * RES( 1, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 2, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 3, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 4, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 5, OP1, OP2, OP3, OP4, D, L ) = ZERO DO 210, R = 1, RUNS IF( LSAME( DB3LIB, 'U' ) )THEN * * Time the user-supplied library. Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 20, J = 1, NMAX DO 10, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 10 CONTINUE 20 CONTINUE TM2 = DSECND( ) CALL DSYMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM3 = DSECND( ) END IF IF( TABSUB( 2 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN DO 40, J = 1, NMAX DO 30, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 30 CONTINUE 40 CONTINUE TM4 = DSECND( ) CALL DSYRK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), $ BETA, C, LDA( L ) ) TM5 = DSECND( ) END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN DO 60, J = 1, NMAX DO 50, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 50 CONTINUE 60 CONTINUE TM6 = DSECND( ) CALL DSYR2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM7 = DSECND( ) END IF IF( TABSUB( 4 ) )THEN DO 80, J = 1, NMAX DO 70, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 70 CONTINUE 80 CONTINUE TM8 = DSECND( ) CALL DTRMM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM9 = DSECND( ) END IF IF( TABSUB( 5 ) )THEN DO 100, J = 1, NMAX DO 90, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 90 CONTINUE 100 CONTINUE TM10 = DSECND( ) CALL DTRSM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM11 = DSECND( ) END IF ELSE IF( LSAME( DB3LIB, 'G' ) )THEN * * Time the built-in GEMM-Based Level 3 BLAS library (DGB02, * DGB04, DGB06, DGB08, and DGB09). Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 120, J = 1, NMAX DO 110, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 110 CONTINUE 120 CONTINUE TM2 = DSECND( ) CALL DGB02( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM3 = DSECND( ) END IF IF( TABSUB( 2 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN DO 140, J = 1, NMAX DO 130, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 130 CONTINUE 140 CONTINUE TM4 = DSECND( ) CALL DGB04( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), $ BETA, C, LDA( L ) ) TM5 = DSECND( ) END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN DO 160, J = 1, NMAX DO 150, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 150 CONTINUE 160 CONTINUE TM6 = DSECND( ) CALL DGB06( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM7 = DSECND( ) END IF IF( TABSUB( 4 ) )THEN DO 180, J = 1, NMAX DO 170, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 170 CONTINUE 180 CONTINUE TM8 = DSECND( ) CALL DGB08( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM9 = DSECND( ) END IF IF( TABSUB( 5 ) )THEN DO 200, J = 1, NMAX DO 190, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 190 CONTINUE 200 CONTINUE TM10 = DSECND( ) CALL DGB09( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM11 = DSECND( ) END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown Level 3 BLAS library choosen: ', DB3LIB, '.' END IF * * Compute the performance of DSYMM in Mflops. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM3 - TM2 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN NOPS = ( 2*M + 1 )*M*N + MIN( M*N, ( M*( M+1 ) )/2 ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN NOPS = ( 2*N + 1 )*M*N + MIN( M*N, ( N*( N+1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 1, OP1, OP2, 1, 1, D, L ).LT.SPEED )THEN RES( 1, OP1, OP2, 1, 1, D, L ) = SPEED END IF END IF * * Compute the performance of DSYRK in Mflops. * IF( TABSUB( 2 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM5 - TM4 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( 2*K + 1 )*( N*( N+1 )/2 ) + MIN( N*K, N*( N+1 )/2 ) IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 2, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 2, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of DSYR2K in Mflops. * IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM7 - TM6 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( 4*K + 1 )*( N*( N+1 )/2 ) + MIN( 2*N*K, N*( N+1 ) ) IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 3, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 3, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of DTRMM in Mflops. * IF( TABSUB( 4 ) )THEN TIME = ( TM9 - TM8 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN NOPS = M*M*N + MIN( M*N, ( M*( M + 1 ) )/2 ) ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN NOPS = M*M*N - M*N + MIN( M*N, ( M*( M + 1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN NOPS = M*N*N + MIN( M*N, ( N*( N + 1 ) )/2 ) ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN NOPS = M*N*N - M*N + MIN( M*N, ( N*( N + 1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 4, OP1, OP2, OP3, OP4, D, L ).LT.SPEED )THEN RES( 4, OP1, OP2, OP3, OP4, D, L ) = SPEED END IF END IF * * Compute the performance of DTRSM in Mflops. * IF( TABSUB( 5 ) )THEN TIME = ( TM11 - TM10 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN NOPS = M*M*N + MIN( M*N, ( M*( M + 1 ) )/2 ) ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN NOPS = M*M*N - M*N + MIN( M*N, ( M*( M + 1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN NOPS = M*N*N + MIN( M*N, ( N*( N + 1 ) )/2 ) ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN NOPS = M*N*N - M*N + MIN( M*N, ( N*( N + 1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 5, OP1, OP2, OP3, OP4, D, L ).LT.SPEED )THEN RES( 5, OP1, OP2, OP3, OP4, D, L ) = SPEED END IF END IF 210 CONTINUE * * ------ Stop indentation ------ * 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 CONTINUE 270 CONTINUE * * ------ Continue indentation ------ * RETURN * * End of DGBT01. * END SHAR_EOF fi # end of overwriting check if test -f 'dgbt02.f' then echo shar: will not over-write existing file "'dgbt02.f'" else cat << SHAR_EOF > 'dgbt02.f' SUBROUTINE DGBT02( TABSUB, SIDE, NSIDE, NUPLO, TRNS, NTRNS, NDIAG, $ DIM1, DIM2, NDIM, LDA, NLDA, ALPHA, BETA, $ A, B, C, LD, NMAX, NERR, MXSUB, MXOPT, $ MXDIM, MXLDA, RUNS, RES ) * .. Scalar Arguments .. INTEGER LD, NMAX, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXDIM, MXLDA, RUNS DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER SIDE( MXOPT ), TRNS( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) DOUBLE PRECISION A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ), $ RES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, MXDIM, $ MXLDA ) * * * Determine problem configurations for DGEMM that, for timing purposes, * "correspond" to problem configurations for the remaining Level 3 BLAS * routines. Time DGEMM for problems that correspond to the Level 3 BLAS * problems timed in DGBT01. Return the performance of DGEMM in Mflops. * * DGBT02 calls a DOUBLE PRECISION function DSECND with no arguments, * which is assumed to return the user time for a process in seconds * from some fixed starting-time. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, J, M, N, K, NOPS, $ D, L, R, OP1, OP2, OP3, OP4 DOUBLE PRECISION TIME, SPEED, TM0, TM1, TM2, TM3, TM4, TM5, TM6, $ TM7, TM8, TM9 * .. Intrinsic Functions .. INTRINSIC DBLE, MIN * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DSECND EXTERNAL LSAME, DSECND * .. External Subroutines .. EXTERNAL DGEMM * .. Parameters .. DOUBLE PRECISION ZERO, ONE, SCALE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, SCALE = 1.0D+6 ) * .. * .. Executable Statements .. TM0 = DSECND( ) TM0 = DSECND( ) TM0 = DSECND( ) TM1 = DSECND( ) * * ------ Stop indentation ------ * DO 180, L = 1, NLDA DO 170, OP1 = 1, NSIDE DO 160, OP3 = 1, NTRNS DO 150, D = 1, NDIM * * ------ Continue indentation ------ * RES( 1, OP1, 1, OP3, 1, D, L ) = ZERO RES( 2, OP1, 1, OP3, 1, D, L ) = ZERO RES( 3, OP1, 1, OP3, 1, D, L ) = ZERO RES( 4, OP1, 1, OP3, 1, D, L ) = ZERO RES( 5, OP1, 1, OP3, 1, D, L ) = ZERO DO 140, R = 1, RUNS * * Time the user-supplied library. Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1 )THEN DO 20, J = 1, NMAX DO 10, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 10 CONTINUE 20 CONTINUE * * Time DGEMM for a problem that corresponds to the following * problem for DSYMM: * DSYMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) * IF( LSAME( SIDE( OP1 ), 'L' ) )THEN * * Use K = M. * TM2 = DSECND( ) CALL DGEMM( 'N', 'N', DIM1( D ), DIM2( D ), DIM1( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM3 = DSECND( ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN * * Use K = N. * TM2 = DSECND( ) CALL DGEMM( 'N', 'N', DIM1( D ), DIM2( D ), DIM2( D ), $ ALPHA, B, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM3 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' STOP END IF END IF IF( TABSUB( 2 ).AND.OP1.EQ.1 )THEN DO 40, J = 1, NMAX DO 30, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 30 CONTINUE 40 CONTINUE * * Time DGEMM for a problem that corresponds to the following * problem for DSYRK: * DSYRK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), BETA, C, LDA( L ) ) * Use M = N and B = A in the call to DGEMM. * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM4 = DSECND( ) CALL DGEMM( 'N', 'T', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM5 = DSECND( ) ELSE IF( LSAME( TRNS( OP3 ), 'T' ) )THEN TM4 = DSECND( ) CALL DGEMM( 'T', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM5 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 3 ).AND.OP1.EQ.1 )THEN DO 60, J = 1, NMAX DO 50, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 50 CONTINUE 60 CONTINUE * * Time DGEMM for a problem that corresponds to the following * problem for DSYR2K: * DSYR2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM6 = DSECND( ) CALL DGEMM( 'N', 'T', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM7 = DSECND( ) ELSE IF( LSAME( TRNS( OP3 ), 'T' ) )THEN TM6 = DSECND( ) CALL DGEMM( 'T', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM7 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 4 ).OR.TABSUB( 5 ) )THEN DO 80, J = 1, NMAX DO 70, I = 1, LD C( I, J ) = ONE + 0.01D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( LD*NMAX+1 ) 70 CONTINUE 80 CONTINUE * * Time DGEMM for a problem that corresponds to the following * problems for DTRMM and DTRSM: * DTRMM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), * DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, * A, LDA( L ), C, LDA( L ) ) * DTRSM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), * DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, * A, LDA( L ), C, LDA( L ) ) * IF( LSAME( SIDE( OP1 ), 'L' ) )THEN * * C := alpha*A*C + C or C := alpha*A'*C + C. Use K = M. * TM8 = DSECND( ) CALL DGEMM( TRNS( OP3 ), 'N', DIM1( D ), DIM2( D ), $ DIM1( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ ONE, C, LDA( L ) ) TM9 = DSECND( ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN * * C := alpha*C*A + C or C := alpha*C*A' + C. Use K = N. * TM8 = DSECND( ) CALL DGEMM( 'N', TRNS( OP3 ), DIM1( D ), DIM2( D ), $ DIM2( D ), ALPHA, B, LDA( L ), A, LDA( L ), $ ONE, C, LDA( L ) ) TM9 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' STOP END IF END IF * * Compute the performance of DGEMM in Mflops for problem * configurations that corresponds to DSYMM. * IF( TABSUB( 1 ).AND.OP3.EQ.1 )THEN TIME = ( TM3 - TM2 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN NOPS = ( 2*M + 1 )*M*N + MIN( M*N, M*M ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN NOPS = ( 2*N + 1 )*M*N + MIN( M*N, N*N ) END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 1, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 90, OP2 = 1, NUPLO RES( 1, OP1, OP2, OP3, 1, D, L ) = SPEED 90 CONTINUE END IF END IF * * Compute the performance of DGEMM in Mflops for problem * configurations that corresponds to DSYRK. * IF( TABSUB( 2 ).AND.OP1.EQ.1 )THEN TIME = ( TM5 - TM4 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( 2*K + 1 )*N*N + MIN( N*K, N*N ) IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 2, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 100, OP2 = 1, NUPLO RES( 2, OP1, OP2, OP3, 1, D, L ) = SPEED 100 CONTINUE END IF END IF * * Compute the performance of DGEMM in Mflops for problem * configurations that corresponds to DSYR2K. * IF( TABSUB( 3 ).AND.OP1.EQ.1 )THEN TIME = ( TM7 - TM6 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( 2*K + 1 )*N*N + MIN( N*K, N*N ) IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 3, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 110, OP2 = 1, NUPLO RES( 3, OP1, OP2, OP3, 1, D, L ) = SPEED 110 CONTINUE END IF END IF * * Compute the performance of DGEMM in Mflops for problem * configurations that corresponds to DTRMM and DTRSM. * IF( TABSUB( 4 ).OR.TABSUB( 5 ) )THEN TIME = ( TM9 - TM8 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN NOPS = ( 2*M - 1 )*M*N + MIN( M*N, M*M ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN NOPS = ( 2*N - 1 )*M*N + MIN( M*N, N*N ) END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 4, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 130, OP2 = 1, NUPLO DO 120, OP4 = 1, NDIAG RES( 4, OP1, OP2, OP3, OP4, D, L ) = SPEED RES( 5, OP1, OP2, OP3, OP4, D, L ) = SPEED 120 CONTINUE 130 CONTINUE END IF END IF 140 CONTINUE * * ------ Stop indentation ------ * 150 CONTINUE 160 CONTINUE 170 CONTINUE 180 CONTINUE * * ------ Continue indentation ------ * RETURN * * End of DGBT02. * END SHAR_EOF fi # end of overwriting check if test -f 'dgbtim.f' then echo shar: will not over-write existing file "'dgbtim.f'" else cat << SHAR_EOF > 'dgbtim.f' * * GEMM-Based Level 3 BLAS Benchmark * Double Precision * * The GEMM-Based Level 3 BLAS Benchmark is a tool for performance * evaluation of Level 3 BLAS kernel programs. With the announcement of * LAPACK, the need for high performance Level 3 BLAS kernels became * apparent. LAPACK is based on calls to the Level 3 BLAS kernels. This * benchmark measures and compares performance of a set of user supplied * Level 3 BLAS implementations and of the GEMM-Based Level 3 BLAS * implementations permanently included in the benchmark. The purpose of * the benchmark is to facilitate the user in determining the quality of * different Level 3 BLAS implementations. The included GEMM-Based * Level 3 BLAS routines provide a lower limit on the performance to be * expected from a highly optimized Level 3 BLAS library. * * All routines are written in Fortran 77 for portability. No changes to * the code should be necessary in order to run the programs correctly * on different target machines. In fact, we strongly recommend the user * to avoided changes, except to the user specified parameters and to * UNIT numbers for input and output communication. This will ensure * that performance results from different target machines are * comparable. * * The program calls a DOUBLE PRECISION function DSECND with no * arguments, which is assumed to return the user time for a process in * seconds from some fixed starting-time. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * PROGRAM DGBTIM * .. Parameters .. INTEGER NIN, NOUT, NERR, IERR PARAMETER ( NIN = 5, NOUT = 6, NERR = 6 ) INTEGER LD, NMAX PARAMETER ( LD = 530, NMAX = LD ) INTEGER LLN, LST, LNM PARAMETER ( LLN = 256, LST = 50, LNM = 6 ) INTEGER MXTAB, MXOPT, MXDIM, MXLDA, MXSUB, MXRUNS PARAMETER ( MXTAB = 6, MXSUB = 5, MXOPT = 2, MXDIM = 36, $ MXLDA = 24, MXRUNS = 20 ) DOUBLE PRECISION ONE, ALPHA, BETA PARAMETER ( ONE = 1.0D+0, ALPHA = 0.9D+0, BETA = 1.1D+0 ) * .. Local Scalars .. INTEGER I, IB, IE, IX, J, JB, JE, KB, KE, $ NTAB, NSIDE, NUPLO, NTRNS, NDIAG, NDIM1, NDIM2, $ NLDA, NRUNS, RUNS, MATCH LOGICAL ERR1, ERR2, ERR3, ERR4, SUB * .. Intrinsic Functions .. INTRINSIC DBLE * .. External Functions .. INTEGER EOLN LOGICAL LSAME, GETWRD EXTERNAL LSAME, GETWRD, EOLN * .. External Subroutines .. EXTERNAL DGBT01, DGBT02, DGBTP1, DGBTP2 * .. Local Arrays .. INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) LOGICAL SUBCHK( MXSUB ), TABSUB( MXSUB ), TAB( MXTAB ) DOUBLE PRECISION A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ), $ USRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ GBRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ) COMMON / DBKCMN / A, B, C, USRES, GBRES, MMRES CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXOPT ), $ DIAG( MXOPT ) CHARACTER INLN*( LLN ), INSTR*( LST ), BLANK*( LST ), $ LBL*( LST ), NAME( MXSUB )*( LNM ) CHARACTER INLNA( LLN ) EQUIVALENCE ( INLN, INLNA ) * .. Data statements .. DATA NTAB/ 0 /, NRUNS/ 0 /, NSIDE/ 0 /, NUPLO/ 0 /, $ NTRNS/ 0 /, NDIAG/ 0 /, NDIM1/ 0 /, NDIM2/ 0 /, $ NLDA/ 0 / DATA TAB/ MXTAB*.FALSE. /, TABSUB/ MXSUB*.FALSE. /, $ SUBCHK/ MXSUB*.FALSE. /, $ SIDE/ MXOPT*' ' /, UPLO/ MXOPT*' '/, $ TRNS/ MXOPT*' ' /, DIAG/ MXOPT*' '/, $ NAME/ 'DSYMM ', 'DSYRK ', 'DSYR2K', 'DTRMM ', $ 'DTRSM '/, SUB/ .FALSE. / DATA BLANK/' '/, $ LBL /' '/ * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. Store the line in the variable INLN. The first word (token) * of the line is stored in INLN( IB:IE ). * 10 READ( NIN, FMT = 9000, END = 200 ) INLN IF( .NOT.GETWRD( INLNA, LLN, IB, IE ).OR. $ ( INLN( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * If INLN( IB:IE ) contains the key word for a parameter, then read * and store the parameter values given on the same line of the input * file, after the key word. * JB = IB JE = IE I = 0 ERR1 = .FALSE. ERR2 = .FALSE. ERR3 = .FALSE. ERR4 = .FALSE. * * Read the parameters from the line INLN. * IF( INLN( JB:JE ).EQ.'LBL' )THEN * * Read the label of this test. * IF( LBL.NE.BLANK )THEN ERR3 = .TRUE. END IF IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN KE = EOLN( INLNA( JE+1 ), LLN-JE-1 ) JB = JE + KB JE = JE + KE IF( JE-JB+1.GT.LST )THEN ERR4 = .TRUE. ELSE LBL = INLN( JB:JE ) END IF END IF I = 1 ELSE IF( INLN( JB:JE ).EQ.'TAB' )THEN * * Read which tests to be made. * IF( NTAB.NE.0 )THEN ERR3 = .TRUE. END IF 20 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXTAB )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) IX IF( IERR.GT.0.OR.IX.LT.1.OR.IX.GT.MXTAB )THEN ERR1 = .TRUE. END IF IF( TAB( IX ) )THEN ERR1 = .TRUE. END IF TAB( IX ) = .TRUE. ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 20 END IF END IF NTAB = I ELSE IF( INLN( JB:JE ).EQ.'RUNS' )THEN * * Read the number of times each problem is to be executed. The * final performance results are computed using the best timing * result for each problem. * IF( NRUNS.NE.0 )THEN ERR3 = .TRUE. END IF 30 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.1 )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) RUNS IF( IERR.GT.0.OR.RUNS.LT.1.OR.RUNS.GT.MXRUNS )THEN ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 30 END IF END IF NRUNS = I ELSE IF( INLN( IB:IE ).EQ.'SIDE' )THEN * * Read the values for SIDE. * IF( NSIDE.NE.0 )THEN ERR3 = .TRUE. END IF 40 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'L' ) )THEN DO 50, J = 1, I IF( LSAME( SIDE( J ), 'L' ) ) ERR1 = .TRUE. 50 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'R' ) )THEN DO 60, J = 1, I IF( LSAME( SIDE( J ), 'R' ) ) ERR1 = .TRUE. 60 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 SIDE( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 40 END IF END IF NSIDE = I ELSE IF( INLN( IB:IE ).EQ.'UPLO' )THEN * * Read the values for UPLO. * IF( NUPLO.NE.0 )THEN ERR3 = .TRUE. END IF 70 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'U' ) )THEN DO 80, J = 1, I IF( LSAME( UPLO( J ), 'U' ) ) ERR1 = .TRUE. 80 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'L' ) )THEN DO 90, J = 1, I IF( LSAME( UPLO( J ), 'L' ) ) ERR1 = .TRUE. 90 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 UPLO( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 70 END IF END IF NUPLO = I ELSE IF( INLN( IB:IE ).EQ.'TRANS' )THEN * * Read the values for TRANS. * IF( NTRNS.NE.0 )THEN ERR3 = .TRUE. END IF 100 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'N' ) )THEN DO 110, J = 1, I IF( LSAME( TRNS( J ), 'N' ) ) ERR1 = .TRUE. 110 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'T' ) )THEN DO 120, J = 1, I IF( LSAME( TRNS( J ), 'T' ) ) ERR1 = .TRUE. 120 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 TRNS( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 100 END IF END IF NTRNS = I ELSE IF( INLN( IB:IE ).EQ.'DIAG' )THEN * * Read the values for DIAG. * IF( NDIAG.NE.0 )THEN ERR3 = .TRUE. END IF 130 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'N' ) )THEN DO 140, J = 1, I IF( LSAME( DIAG( J ), 'N' ) ) ERR1 = .TRUE. 140 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'U' ) )THEN DO 150, J = 1, I IF( LSAME( DIAG( J ), 'U' ) ) ERR1 = .TRUE. 150 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 DIAG( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 130 END IF END IF NDIAG = I ELSE IF( INLN( IB:IE ).EQ.'DIM1' )THEN * * Read the values for the first matrix dimension (DIM1). * IF( NDIM1.NE.0 )THEN ERR3 = .TRUE. END IF 160 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXDIM )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) DIM1( I ) IF( IERR.GT.0.OR.DIM1( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( DIM1( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 160 END IF END IF NDIM1 = I ELSE IF( INLN( IB:IE ).EQ.'DIM2' )THEN * * Read the values for the second matrix dimension (DIM2). * IF( NDIM2.NE.0 )THEN ERR3 = .TRUE. END IF 170 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXDIM )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) DIM2( I ) IF( IERR.GT.0.OR.DIM2( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( DIM2( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 170 END IF END IF NDIM2 = I ELSE IF( INLN( IB:IE ).EQ.'LDA' )THEN * * Read the values for leading dimension (LDA). * IF( NLDA.NE.0 )THEN ERR3 = .TRUE. END IF 180 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXLDA )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) LDA( I ) IF( IERR.GT.0.OR.LDA( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( LDA( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 180 END IF END IF NLDA = I ELSE IF( INLN( IB:IE ).EQ.'DSYMM'.OR.INLN( IB:IE ).EQ.'DSYRK'.OR. $ INLN( IB:IE ).EQ.'DSYR2K'.OR.INLN( IB:IE ).EQ.'DTRMM'.OR. $ INLN( IB:IE ).EQ.'DTRSM' )THEN * * Read which routines to time. * MATCH = 0 DO 190, I = 1, MXSUB IF( NAME( I ).EQ.INLN( IB:IB+5 ) )THEN MATCH = I IF( SUBCHK( MATCH ) )THEN ERR3 = .TRUE. END IF SUBCHK( MATCH ) = .TRUE. END IF 190 CONTINUE IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE * * Time the routine if the first non-blank character * INLN( JB:JB ) is 'T' or 't'. * TABSUB( MATCH ) = LSAME( INLN( JB:JB ), 'T' ) IF( .NOT.( TABSUB( MATCH ).OR. $ LSAME( INLN( JB:JB ), 'F' ) ) )THEN ERR1 = .TRUE. END IF SUB = SUB.OR.TABSUB( MATCH ) I = 1 ELSE I = 0 END IF ELSE WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: Unknown parameter ', INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP END IF * IF( I.EQ.0 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: No values or erroneous values given ', $ 'for the parameter ', INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR1 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Erroneus value or too many values for the parameter ', $ INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR2 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Value too large for ', INLN( IB:IE ), '. Max ', NMAX, '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR3 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Multiple specifications of the input parameter ', $ INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR4 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = 9010 ) $ 'The label of this test is too long. Max ', LST, $ ' characters.' WRITE( NERR, FMT = * ) STOP END IF GO TO 10 * 200 CONTINUE IF( NTAB.LE.0 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: No results are chosen to be presented' WRITE( NERR, FMT = * ) $ ' (see the parameter TAB).' WRITE( NERR, FMT = * ) STOP END IF IF( ( TAB( 2 ).OR.TAB( 3 ).OR.TAB( 4 ).OR.TAB( 5 ).OR.TAB( 6 ) ) $ .AND.( NRUNS.LE.0.OR.NSIDE.LE.0.OR.NUPLO.LE.0.OR. $ NTRNS.LE.0.OR.NDIAG.LE.0.OR.NDIM1.LE.0.OR. $ NDIM2.LE.0.OR.NLDA.LE.0.OR.( .NOT.SUB ) ) )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: A parameter, or values for a parameter, is missing.' WRITE( NERR, FMT = * ) $ 'One (or more) of the input parameters RUNS, SIDE, UPLO,' WRITE( NERR, FMT = * ) $ 'TRANS, DIAG, DIM1, DIM2, LDA are missing, or none of the' WRITE( NERR, FMT = * ) $ 'routines DSYMM, DSYRK, DSYR2K, DTRMM, and DTRSM are marked' WRITE( NERR, FMT = * ) $ 'to be timed', '.' WRITE( NERR, FMT = * ) STOP END IF IF( NDIM1.NE.NDIM2 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: Different number of dimensions ', $ 'for DIM1 and DIM2', '.' WRITE( NERR, FMT = * ) STOP END IF * * Initialize the matrices A and B. * DO 220, J = 1, NMAX DO 210, I = 1, NMAX A( I, J ) = ONE + 0.08D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) 210 CONTINUE 220 CONTINUE DO 240, J = 1, NMAX DO 230, I = 1, NMAX B( I, J ) = ONE + 0.04D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) 230 CONTINUE 240 CONTINUE * * Time the routines and calculate the results. * IF( TAB( 2 ).OR.TAB( 6 ) )THEN * * Time the internal GEMM-Based Level 3 BLAS routines (DGB02, * DGB04, DGB08, DGB08, and DGB09). * CALL DGBT01( 'G', TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXDIM, MXLDA, RUNS, GBRES ) END IF IF( TAB( 1 ).OR.TAB( 3 ).OR.TAB( 5 ).OR.TAB( 6 ) )THEN * * Time the user-supplied Level 3 BLAS library. * CALL DGBT01( 'U', TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXDIM, MXLDA, RUNS, USRES ) END IF IF( TAB( 1 ).OR.TAB( 4 ).OR.TAB( 5 ) )THEN * * Time DGEMM using user specified parameters. * CALL DGBT02( TABSUB, SIDE, NSIDE, NUPLO, TRNS, NTRNS, NDIAG, $ DIM1, DIM2, NDIM1, LDA, NLDA, ALPHA, BETA, $ A, B, C, LD, NMAX, NERR, MXSUB, MXOPT, $ MXDIM, MXLDA, RUNS, MMRES ) END IF IF( TAB( 1 ) )THEN * * Calculate and print the collected benchmark result. * CALL DGBTP1( TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, NTRNS, $ DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, NOUT, $ NERR, MXSUB, MXOPT, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES ) END IF IF( TAB( 2 ).OR.TAB( 3 ).OR.TAB( 4 ).OR.TAB( 5 ).OR.TAB( 6 ) )THEN * * Calculate and print the results of TAB choice 2 - 6. * CALL DGBTP2( TAB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ NOUT, MXTAB, MXSUB, MXOPT, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES, GBRES ) END IF * STOP * 9000 FORMAT( A ) 9010 FORMAT( 1X, A, I3, A ) 9020 FORMAT( I50 ) * * End of DGBTIM. * END SHAR_EOF fi # end of overwriting check if test -f 'dgbtp1.f' then echo shar: will not over-write existing file "'dgbtp1.f'" else cat << SHAR_EOF > 'dgbtp1.f' SUBROUTINE DGBTP1( TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, NTRNS, $ DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, NOUT, $ NERR, MXSUB, MXOPT, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES ) * .. Scalar Arguments .. INTEGER NOUT, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXDIM, MXLDA, RUNS DOUBLE PRECISION ALPHA, BETA * .. Parameters .. INTEGER LST PARAMETER ( LST = 50 ) * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER LBL*( LST ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXOPT ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) DOUBLE PRECISION USRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ) * * * DGBTP1 prints the collected benchmark result which is calculated from * performance results of the user-supplied Level 3 routines for * problems specified in the input file. The result consists of a tuple * ( x, y ), where x is the mean value of the GEMM-Efficiency and y is * the mean value of the performance of DGEMM in megaflops. DGEMM is * timed for problems corresponding to those specified for the remaining * Level 3 routines. * * The purpose of the collected benchmark result is to provide an * overall performance measure of the user-supplied Level 3 BLAS * routines. The intention is to expose the capacity of the target * machine for these kinds of problems and to show how well the routines * utilize the machine. Furthermore, the collected result is intended to * be easy to compare between different target machines. See the README * and INSTALL files for further information. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, D, L, NTIM, OP1, OP2, OP3 DOUBLE PRECISION SPEED, EFF, MM, MMSUM, EFSUM * .. Intrinsic Functions .. INTRINSIC DBLE * .. Parameters .. DOUBLE PRECISION ZERO INTEGER MXBSUB PARAMETER ( ZERO = 0.0D+0, MXBSUB = 5 ) * .. * .. Executable Statements .. IF( MXSUB.GT.MXBSUB )THEN WRITE( NERR, FMT = 9000 ) STOP END IF * MMSUM = ZERO EFSUM = ZERO NTIM = 0 * * ------ Stop indentation ------ * DO 50, L = 1, NLDA DO 40, OP1 = 1, NSIDE DO 30, OP2 = 1, NUPLO DO 20, OP3 = 1, NTRNS DO 10, D = 1, NDIM * * ------ Continue indentation ------ * * * Compute the sum of the performance of DGEMM in megaflops (MMSUM) * and the sum of the GEMM-Efficiency (EFSUM). * IF( TABSUB( 1 ).AND.OP3.EQ.1 )THEN MM = MMRES( 1, OP1, OP2, 1, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 1, OP1, OP2, 1, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 2 ).AND.OP1.EQ.1 )THEN MM = MMRES( 2, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 2, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 3 ).AND.OP1.EQ.1 )THEN MM = MMRES( 3, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 3, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 4 ) )THEN MM = MMRES( 4, OP1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 4, OP1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 5 ) )THEN MM = MMRES( 5, OP1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 5, OP1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF * * ------ Stop indentation ------ * 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE * * ------ Continue indentation ------ * * * Compute the collected benchmark result ( x, y ) as the mean value * of the GEMM-Efficiency ( x ) and the mean value of the performance * of DGEMM in megaflops ( y ). * SPEED = MMSUM/DBLE( NTIM ) EFF = EFSUM/DBLE( NTIM ) * * Print an introduction and the collected benchmark result. * WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9020 ) WRITE( NOUT, FMT = 9030 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9040 ) RUNS WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9050 ) WRITE( NOUT, FMT = 9060 ) 'SIDE ', ( SIDE( I ), I = 1, NSIDE ) WRITE( NOUT, FMT = 9060 ) 'UPLO ', ( UPLO( I ), I = 1, NUPLO ) WRITE( NOUT, FMT = 9060 ) 'TRANS ', ( TRNS( I ), I = 1, NTRNS ) WRITE( NOUT, FMT = 9060 ) 'DIAG ', ( DIAG( I ), I = 1, NDIAG ) WRITE( NOUT, FMT = 9070 ) 'DIM1 ', ( DIM1( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9070 ) 'DIM2 ', ( DIM2( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9070 ) 'LDA ', ( LDA( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9080 ) 'ALPHA ', ALPHA WRITE( NOUT, FMT = 9080 ) 'BETA ', BETA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9090 ) LBL WRITE( NOUT, FMT = 9100 ) EFF, SPEED WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) * RETURN * * Print formats. * 9000 FORMAT( 1X, 'Error: The collected benchmark result could not ', $ 'be obtained.',/, $ 1X, 'The value for the input parameter MXSUB is too ', $ 'large.' ) 9010 FORMAT( 1X, 'Error: The collected benchmark result could not ', $ 'be obtained.',/, $ 1X, 'Execution time for DGEMM is zero.' ) 9020 FORMAT( 17X, '**** GEMM-Based Level 3 BLAS Benchmark ****' ) 9030 FORMAT( 27X, 'Collected Benchmark Result',/, $ 32X, 'Double Precision' ) 9040 FORMAT( 2X, 'The collected benchmark result is a tuple ', $ '( x, y ) where x is the mean',/, $ 2X, 'value of the GEMM-Efficiency and y is the mean ', $ 'value of the performance',/, $ 2X, 'of DGEMM in megaflops (see the README file). The ', $ 'benchmark result is',/, $ 2X, 'based on the shortest of', I3,' runs for each ', $ 'problem configuration.' ) 9050 FORMAT( 8X, 'Input parameters.' ) 9060 FORMAT( 8X, A, ' ', 10( A, ' ' ) ) 9070 FORMAT( 8X, A, 1X, 12( I5 ), 2( /, 16X, 12( I5 ) ) ) 9080 FORMAT( 8X, A, F6.1 ) 9090 FORMAT( 8X, 'Test label: ', A ) 9100 FORMAT( 8X, 'Collected result: (', F7.2,',', F9.1,' )' ) 9110 FORMAT( 1X, '**************************************************', $ '****************************' ) * * End of DGBTP1. * END SHAR_EOF fi # end of overwriting check if test -f 'dgbtp2.f' then echo shar: will not over-write existing file "'dgbtp2.f'" else cat << SHAR_EOF > 'dgbtp2.f' SUBROUTINE DGBTP2( TAB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, $ NOUT, MXTAB, MXSUB, MXOPT, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES, GBRES ) * .. Scalar Arguments .. INTEGER NOUT, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXTAB, MXSUB, MXOPT, MXDIM, MXLDA, RUNS DOUBLE PRECISION ALPHA, BETA * .. Parameters .. INTEGER LST PARAMETER ( LST = 50 ) * .. Array Arguments .. LOGICAL TABSUB( MXSUB ), TAB( MXTAB ) CHARACTER LBL*( LST ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXOPT ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) DOUBLE PRECISION USRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ GBRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ) * * * DGBTP2 prints tables showing detailed performance results and * comparisons between the user-supplied and the built-in GEMM-Based * Level 3 BLAS routines. The table results are intended for program * developers and others who are interested in detailed performance * presentations. Performance of the user-supplied and the built-in * GEMM-Based Level 3 BLAS routines are shown. The tables also show * GEMM-Efficiency and GEMM-Ratio. See the README and INSTALL files * for further information. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER D, I, L, NTIM, OP1, OP2, OP3, OP4 DOUBLE PRECISION MM, GE, GB, GR, US * .. Parameters .. INTEGER MXTOTS, LLN DOUBLE PRECISION ZERO, HUGE PARAMETER ( MXTOTS = 6, LLN = 256, ZERO = 0.0D+0, $ HUGE = 1.0D+10 ) INTEGER B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, B11, $ E1, E2, E3, E4, E5, E6, E7, E8, E9, E10, E11 PARAMETER ( B1 = 1, B2 = 3, B3 = 5, B4 = 7, B5 = 9, $ B6 = 16, B7 = 23, B8 = 34, B9 = 45, B10 = 56, $ B11 = 66, $ E1 = 2, E2 = 4, E3 = 6, E4 = 8, E5 = 15, $ E6 = 22, E7 = 33, E8 = 44, E9 = 55, E10 = 65, $ E11 = 74 ) * .. Local Arrays .. CHARACTER OUTLN*( LLN ), OUTLN2*( LLN ), OUTLN3*( LLN ) DOUBLE PRECISION MI( MXTOTS ), MA( MXTOTS ), SU( MXTOTS ) * .. * .. Executable Statements .. * * Print an introduction. * WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9000 ) WRITE( NOUT, FMT = 9010 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9020 ) WRITE( NOUT, FMT = 9030 ) 'SIDE ', ( SIDE( I ), I = 1, NSIDE ) WRITE( NOUT, FMT = 9030 ) 'UPLO ', ( UPLO( I ), I = 1, NUPLO ) WRITE( NOUT, FMT = 9030 ) 'TRANS ', ( TRNS( I ), I = 1, NTRNS ) WRITE( NOUT, FMT = 9030 ) 'DIAG ', ( DIAG( I ), I = 1, NDIAG ) WRITE( NOUT, FMT = 9040 ) 'DIM1 ', ( DIM1( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9040 ) 'DIM2 ', ( DIM2( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9040 ) 'LDA ', ( LDA( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9050 ) 'ALPHA ', ALPHA WRITE( NOUT, FMT = 9050 ) 'BETA ', BETA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9060 ) RUNS WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9070 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9080 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9090 ) LBL WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) * * Print result tables for DSYMM. * IF( TABSUB( 1 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'DSYMM ', $ ' OPTIONS = SIDE,UPLO' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 50, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 10, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 10 CONTINUE NTIM = 0 DO 40, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 30, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 20, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 1, OP1, OP2, 1, 1, D, L ) MM = MMRES( 1, OP1, OP2, 1, 1, D, L ) GB = GBRES( 1, OP1, OP2, 1, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B7:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 20 CONTINUE 30 CONTINUE 40 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 50 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for DSYRK. * IF( TABSUB( 2 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'DSYRK ', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 100, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 60, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 60 CONTINUE NTIM = 0 DO 90, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 80, OP3 = 1, NTRNS WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 70, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 2, 1, OP2, OP3, 1, D, L ) MM = MMRES( 2, 1, OP2, OP3, 1, D, L ) GB = GBRES( 2, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 70 CONTINUE 80 CONTINUE 90 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 100 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for DSYR2K. * IF( TABSUB( 3 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'DSYR2K', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 150, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 110, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 110 CONTINUE NTIM = 0 DO 140, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 130, OP3 = 1, NTRNS WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 120, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 3, 1, OP2, OP3, 1, D, L ) MM = MMRES( 3, 1, OP2, OP3, 1, D, L ) GB = GBRES( 3, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 120 CONTINUE 130 CONTINUE 140 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 150 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for DTRMM. * IF( TABSUB( 4 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'DTRMM ', $ 'OPTIONS = SIDE,UPLO,TRANS,DIAG' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 220, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 160, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 160 CONTINUE NTIM = 0 DO 210, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 200, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) DO 190, OP3 = 1, NTRNS WRITE( OUTLN( B3:E3 ), FMT = 9130 ) TRNS( OP3 ) DO 180, OP4 = 1, NDIAG WRITE( OUTLN( B4:E4 ), FMT = 9130 ) DIAG( OP4 ) DO 170, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 4, OP1, OP2, OP3, OP4, D, L ) MM = MMRES( 4, OP1, OP2, OP3, OP4, D, L ) GB = GBRES( 4, OP1, OP2, OP3, OP4, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 170 CONTINUE 180 CONTINUE 190 CONTINUE 200 CONTINUE 210 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 220 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for DTRSM. * IF( TABSUB( 5 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'DTRSM ', $ 'OPTIONS = SIDE,UPLO,TRANS,DIAG' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 290, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 230, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 230 CONTINUE NTIM = 0 DO 280, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 270, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) DO 260, OP3 = 1, NTRNS WRITE( OUTLN( B3:E3 ), FMT = 9130 ) TRNS( OP3 ) DO 250, OP4 = 1, NDIAG WRITE( OUTLN( B4:E4 ), FMT = 9130 ) DIAG( OP4 ) DO 240, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 5, OP1, OP2, OP3, OP4, D, L ) MM = MMRES( 5, OP1, OP2, OP3, OP4, D, L ) GB = GBRES( 5, OP1, OP2, OP3, OP4, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9190 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 240 CONTINUE 250 CONTINUE 260 CONTINUE 270 CONTINUE 280 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 290 CONTINUE END IF WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9260 ) * RETURN * * Print formats. * 9000 FORMAT( 17X, '**** GEMM-Based Level 3 BLAS Benchmark ****' ) 9010 FORMAT( 33X, 'Table Results',/, $ 32X, 'Double Precision' ) 9020 FORMAT( 8X, 'Input parameters.' ) 9030 FORMAT( 8X, A, 3X, 10( A, ' ' ) ) 9040 FORMAT( 8X, A, 1X, 12( I5 ), 2( /, 16X, 12( I5 ) ) ) 9050 FORMAT( 8X, A, F6.1 ) 9060 FORMAT( 8X, 'Results are based on the shortest execution time ', $ 'of ', I2, ' runs for ',/, $ 8X, 'each problem configuration.' ) 9070 FORMAT( 27X, 'Performance of a user-supplied',/, $ 27X, 'Level 3 BLAS routine (megaflops).',/, $ 8X, 'GEMM-Efficiency = -------------------------------', $ '----',/, $ 27X, 'Performance of the user-supplied',/, $ 27X, 'DGEMM routine (megaflops).' ) 9080 FORMAT( 22X, 'Performance for the internal GEMM-Based',/, $ 22X, 'Level 3 BLAS routine Dxxxx (megaflops).',/, $ 8X, 'GEMM-Ratio = ------------------------------------', $ '-----',/, $ 22X, 'Performance of the user-supplied',/, $ 22X, 'Level 3 BLAS routine Dxxxx (megaflops).' ) 9090 FORMAT( 8X, 'Test label: ', A ) 9100 FORMAT( 2X, A, 38X, A ) 9110 FORMAT( 31X, 'GEMM- User-', /, $ 29X,'Based lib suppl lib DGEMM GEMM- GEMM-', /, $ 2X, 'OPTIONS ', A,' ', A,' ', $ 'Mflops Mflops Mflops Eff. Ratio', /, $ 2X, '==================================================', $ '=========================' ) 9120 FORMAT( 2X, '( LDA = ', I4, ' )' ) 9130 FORMAT( A ) 9140 FORMAT( I7 ) 9150 FORMAT( F11.1 ) 9160 FORMAT( ' ' ) 9170 FORMAT( F10.2 ) 9180 FORMAT( ' ' ) 9190 FORMAT( F9.2 ) 9200 FORMAT( ' ' ) 9210 FORMAT( 2X, A ) 9220 FORMAT( 2X, '--------------------------------------------------', $ '-------------------------' ) 9230 FORMAT( 'Min ', 15X ) 9240 FORMAT( 'Max ', 15X ) 9250 FORMAT( 'Mean ', 15X ) 9260 FORMAT( 1X, '**************************************************', $ '****************************' ) * * End of DGBTP2. * END SHAR_EOF fi # end of overwriting check if test -f 'dmark01.in' then echo shar: will not over-write existing file "'dmark01.in'" else cat << SHAR_EOF > 'dmark01.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * DMARK01 * * * We propose two standard test suits for the collected benchmark * result, DMARK01 and DMARK02 (see the files 'dmark01.in' and * 'dmark02.in'). These tests are designed to show performance of the * user-supplied Level 3 library for problem sizes that are likely to * often be requested by a calling routine. This imply problems that * presumably constitute a large part of computations in routines which * use the Level 3 BLAS as their major computational kernels. LAPACK * implements blocked algorithms which are based on calls to the Level 3 * BLAS. The problems in the two tests are similar. However, some of the * matrix dimensions are larger in DMARK02 than in DMARK01. This * corresponds to larger matrix blocks in the calling routine. The tests * are expected to match various target machines differently. * Performance results may depend strongly on sizes of different storage * units in the memory hierarchy. The size of the cache memory, for * instance, may be decisive. For this reason, we propose two standard * tests instead of one. * * *** Label of this test *** LBL DMARK01 *** Benchmark results to be presented *** TAB 1 3 4 5 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 3 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T DIAG N U DIM1 16 32 512 512 512 DIM2 512 512 16 32 512 LDA 512 530 *** Routines to be timed *** DSYMM T DSYRK T DSYR2K T DTRMM T DTRSM T SHAR_EOF fi # end of overwriting check if test -f 'dmark02.in' then echo shar: will not over-write existing file "'dmark02.in'" else cat << SHAR_EOF > 'dmark02.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * DMARK02 * * * We propose two standard test suits for the collected benchmark * result, DMARK01 and DMARK02 (see the files 'dmark01.in' and * 'dmark02.in'). These tests are designed to show performance of the * user-supplied Level 3 library for problem sizes that are likely to * often be requested by a calling routine. This imply problems that * presumably constitute a large part of computations in routines which * use the Level 3 BLAS as their major computational kernels. LAPACK * implements blocked algorithms which are based on calls to the Level 3 * BLAS. The problems in the two tests are similar. However, some of the * matrix dimensions are larger in DMARK02 than in DMARK01. This * corresponds to larger matrix blocks in the calling routine. The tests * are expected to match various target machines differently. * Performance results may depend strongly on sizes of different storage * units in the memory hierarchy. The size of the cache memory, for * instance, may be decisive. For this reason, we propose two standard * tests instead of one. * * *** Label of this test *** LBL DMARK02 *** Benchmark results to be presented *** TAB 1 3 4 5 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 3 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T DIAG N U DIM1 64 128 512 512 512 DIM2 512 512 64 128 512 LDA 512 530 *** Routines to be timed *** DSYMM T DSYRK T DSYR2K T DTRMM T DTRSM T SHAR_EOF fi # end of overwriting check if test -f 'dsbpm.f' then echo shar: will not over-write existing file "'dsbpm.f'" else cat << SHAR_EOF > 'dsbpm.f' PROGRAM DSBPM * * DSBPM re-writes GEMM-Based Level 3 BLAS source files replacing lines * containing old PARAMETER statements for user specified parameters, * with lines containing new PARAMETER statements given in an input * file. The user can conveniently assign new values to the PARAMETER * statements in the input file, and then run DSBPM to distribute these * values to the GEMM-based routines. An input file consists of three * different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file (see the input file * 'dgpm.in'). Read the file INSTALL for further instructions. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, IB, IE, JB, JE, KB, KE, LB, LE, NAM, NXTLN LOGICAL PMEOF * .. External Functions .. LOGICAL LNCMP, GETWRD INTEGER EOLN EXTERNAL LNCMP, GETWRD, EOLN * .. Parameters .. INTEGER NPM, NGB, NTMP, NERR PARAMETER ( NPM = 5, NERR = 6, NGB = 10, NTMP = 12 ) INTEGER NLNS, LLN PARAMETER ( NLNS = 10, LLN = 256 ) CHARACTER TMPNAM*( LLN ) PARAMETER ( TMPNAM = 'tmpgb.tmp' ) * .. Local Arrays .. CHARACTER PMLN*( LLN ), GBLN*( LLN ), GBNAM*( LLN ), $ STRS( NLNS, 2 )*( LLN ), BNAM( NLNS )*( LLN ) CHARACTER PMLNA( LLN ), GBLNA( LLN ), GBNAMA( LLN ), $ STRSA( LLN, NLNS, 2 ), BNAMA( LLN, NLNS ) EQUIVALENCE ( PMLN, PMLNA ), ( GBLN, GBLNA ), $ ( GBNAM, GBNAMA ), ( STRS, STRSA ), $ ( BNAM, BNAMA ) * .. Data statements .. DATA BNAM/ $'dgb02.f' ,'dgb04.f' ,'dgb06.f' ,'dgb08.f' ,'dgb09.f' , $'dgb90.f' ,' ',' ','dgb91.f' ,' '/ DATA STRS/ $'dsymm.f' ,'dsyrk.f' ,'dsyr2k.f' ,'dtrmm.f' ,'dtrsm.f' , $'dbigp.f' ,' ',' ','dcld.f' ,' ', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( DIP41 = $$ , DIP42 = $$ ,', $'$ DIP81 = $$ , DIP82 = $$ , DIP83 = $$ ,', $'$ DIP91 = $$ , DIP92 = $$ , DIP93 = $$ )', $'PARAMETER ( LNSZ = $$ , NPRT = $$ , PRTSZ = $$ ,', $'$ LOLIM = $$ , DP = $$ )' / * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. * 10 READ( NPM, FMT = 9000, END = 110 ) GBNAM IF( .NOT.GETWRD( GBNAMA, LLN, IB, IE ).OR. $ ( GBNAM( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * Check if the first word on the line is the name of a file that is * due to be changed. * 20 NAM = -1 PMEOF = .FALSE. DO 30, I = 1, NLNS IF( GBNAM( IB:IE ).EQ.STRS( I, 1 ) )THEN NAM = I IF( .NOT.GETWRD( BNAMA( 1, NAM ), LLN, LB, LE ) )THEN WRITE( NERR, FMT = * ) $ 'Benchmark routine name corresponding to ', $ GBNAM( IB:IE ), ' is missing in DSBPM.' STOP END IF END IF 30 CONTINUE IF( NAM.EQ.-1 )THEN WRITE( NERR, FMT = * )'Unknown routine name: ', GBNAM( IB:IE ) STOP END IF * * Read the next non-blank/non-comment line from the input parameter * file. * 40 READ( NPM, FMT = 9000, END = 110 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 40 END IF * * Copy each line of the GEMM-Based file, except for the lines that * are due to be changed, to the temporary file TMPNAM. Copy the * lines that should be changed from the input parameter file. Check * that the lines in the parameter file are correct compared to STRS. * NXTLN = NAM IF( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN OPEN( NGB, FILE = BNAM( NAM )( LB:LE ), STATUS = 'OLD' ) OPEN( NTMP, FILE = TMPNAM, STATUS = 'NEW' ) 50 READ( NGB, FMT = 9000, END = 80 ) GBLN IF( LNCMP( GBLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN WRITE( NTMP, FMT = 9010 ) PMLN( 1:EOLN( PMLNA, LLN ) ) 60 READ( NPM, FMT = 9000, END = 70 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 60 END IF IF( .NOT.GETWRD( STRSA( 1, NXTLN+1, 1 ), LLN, KB, KE ).AND. $ ( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN+1, 2 ), LLN ) ) $ )THEN NXTLN = NXTLN + 1 END IF ELSE WRITE( NTMP, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) END IF GO TO 50 70 PMEOF = .TRUE. GO TO 50 80 CLOSE( NGB, STATUS = 'DELETE' ) CLOSE( NTMP, STATUS = 'KEEP' ) ELSE WRITE( NERR, FMT = * )'Error in parameter file: ' WRITE( NERR, FMT = * ) PMLN STOP END IF * * Write back the temporary file TMPNAM to the GEMM-Based file and * remove the temporary file. * OPEN( NTMP, FILE = TMPNAM, STATUS = 'OLD' ) OPEN( NGB, FILE = BNAM( NAM )( LB:LE ), STATUS = 'NEW' ) 90 READ( NTMP, FMT = 9000, END = 100 ) GBLN WRITE( NGB, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) GO TO 90 100 CONTINUE CLOSE( NTMP, STATUS = 'DELETE' ) CLOSE( NGB, STATUS = 'KEEP' ) GBNAM = PMLN IB = JB IE = JE * IF( .NOT.PMEOF )THEN GO TO 20 END IF 110 CONTINUE * STOP * 9000 FORMAT( A ) 9010 FORMAT( A ) * * End of DSBPM. * END LOGICAL FUNCTION LNCMP( LN1, LEN1, LN2, LEN2 ) * .. Scalar Arguments .. INTEGER LEN1, LEN2 * .. Array Arguments .. CHARACTER LN1( LEN1 ), LN2( LEN2 ) * * Compare the character strings LN1 and LN2. Return .TRUE. if the * strings are identical except from wild cards ($$) corresponding * to positive integers and except from a different number of * consecutive blanks between tokens. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER I, J LOGICAL MATCH * .. Intrinsic Functions .. INTRINSIC LGE, LLE LOGICAL LGE, LLE * .. * .. Executable Statements .. * * Find the beginning of the next tokens in LN1 and LN2. * I = 1 J = 1 10 IF( ( LN1( I ).EQ.' ' ).AND.( I.LT.LEN1 ) )THEN I = I + 1 GO TO 10 END IF 20 IF( ( LN2( J ).EQ.' ' ).AND.( J.LT.LEN2 ) )THEN J = J + 1 GO TO 20 END IF * * Compare the tokens. * IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.LT.LEN1 ).AND. $ ( J.LT.LEN2 ) )THEN I = I + 1 J = J + 1 GO TO 10 ELSE IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.EQ.LEN1 ).AND. $ ( J.EQ.LEN2 ) )THEN LNCMP = .TRUE. RETURN ELSE IF( ( I.EQ.LEN1 ).AND.( J.EQ.LEN2 ) )THEN LNCMP = .FALSE. RETURN ELSE IF( LN1( I ).EQ.'$' )THEN IF( I.LT.LEN1-1 )THEN IF( LN1( I+1 ).EQ.'$' )THEN I = I + 2 MATCH = .FALSE. 30 IF( ( LGE( LN2( J ), '0' ).AND.LLE( LN2( J ), '9' ) ) $ .AND.( J.LT.LEN2 ) )THEN J = J + 1 MATCH = .TRUE. GO TO 30 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 ELSE IF( LN2( J ).EQ.'$' )THEN IF( J.LT.LEN2-1 )THEN IF( LN2( J+1 ).EQ.'$' )THEN J = J + 2 MATCH = .FALSE. 40 IF( ( LGE( LN1( I ), '0' ).AND.LLE( LN1( I ), '9' ) ) $ .AND.( I.LT.LEN1 ) )THEN I = I + 1 MATCH = .TRUE. GO TO 40 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 END IF * LNCMP = .FALSE. RETURN * * End of LNCMP. * END SHAR_EOF fi # end of overwriting check if test -f 'eoln.f' then echo shar: will not over-write existing file "'eoln.f'" else cat << SHAR_EOF > 'eoln.f' INTEGER FUNCTION EOLN( LN, LLN ) * .. Scalar Arguments .. INTEGER LLN * .. Array Arguments .. CHARACTER LN( LLN ) * * Return the index of the last non-blank character in the last word * (token) of LN. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER IE * .. * .. Executable Statements .. * * Find the end of the last word (token) of LN. * IE = LLN 10 IF( ( LN( IE ).EQ.' ' ).AND.( IE.GE.1 ) )THEN IE = IE - 1 GO TO 10 END IF EOLN = IE * RETURN * * End of EOLN. * END SHAR_EOF fi # end of overwriting check if test -f 'example.in' then echo shar: will not over-write existing file "'example.in'" else cat << SHAR_EOF > 'example.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * Example input file * Double Precision * * * Benchmark results to be presented (parameter TAB): * * 1 The collected benchmark result. * * 2 Performance of the built-in GEMM-Based Level 3 BLAS library * in megaflops. * * 3 Performance of the user-supplied Level 3 BLAS library in * megaflops. * * 4 Performance of the user-supplied DGEMM routine in megaflops. * Problem configurations for DGEMM are chosen to 'correspond' to * those in 2 and 3 for timing purposes, see section 3. * * 5 GEMM-Efficiency of the user-supplied Level 3 routines. * * Performance of a user-supplied * Level 3 BLAS routine (megaflops). * GEMM-Efficiency = ----------------------------------- * Performance of the user-supplied * DGEMM routine (megaflops). * * 6 GEMM-Ratio. * * Performance of the internal GEMM-Based * Level 3 BLAS routine Dxxxx (megaflops). * GEMM-Ratio = ----------------------------------------- * Performance of the user-supplied * Level 3 BLAS routine Dxxxx (megaflops). * *** Label of this test *** LBL Example 1, double precision. *** Benchmark results to be presented *** TAB 1 2 3 4 5 6 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 2 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T DIAG N DIM1 32 64 256 256 DIM2 256 256 32 64 LDA 256 *** Routines to be timed *** DSYMM T DSYRK T DSYR2K T DTRMM T DTRSM T SHAR_EOF fi # end of overwriting check if test -f 'getwrd.f' then echo shar: will not over-write existing file "'getwrd.f'" else cat << SHAR_EOF > 'getwrd.f' LOGICAL FUNCTION GETWRD( LN, LLN, IB, IE ) * .. Scalar Arguments .. INTEGER LLN, IB, IE * .. Array Arguments .. CHARACTER LN( LLN ) * * Read the first non-blank word from the character string LN. Set * the indices IB and IE to the beginning and end of the word, * respectively. Return .TRUE. if a word was found and .FALSE. if no * word was found. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * .. * .. Executable Statements .. * * Find the beginning of the word. * IB = 1 10 IF( ( LN( IB ).EQ.' ' ).AND.( IB.LT.LLN ) )THEN IB = IB + 1 GO TO 10 END IF * * Find the end of the word. * IE = IB 20 IF( IE.LT.LLN )THEN IF( LN( IE+1 ).NE.' ' )THEN IE = IE + 1 GO TO 20 END IF END IF * * Check if any word was found. * IF( LN( IB ).NE.' ' )THEN GETWRD = .TRUE. ELSE GETWRD = .FALSE. END IF * RETURN * * End of GETWRD. * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'newdgpm.in' then echo shar: will not over-write existing file "'newdgpm.in'" else cat << SHAR_EOF > 'newdgpm.in' * * Example of an input file for the program DSGPM containing user * specified parameters. * * The enclosed program DSGPM re-writes GEMM-Based Level 3 BLAS source * files replacing lines containing old PARAMETER statements for user * specified parameters, with lines containing new PARAMETER statements * given in an input file. The user can conveniently assign new values * to the PARAMETER statements in the input file, and then run DSGPM to * distribute these values to the GEMM-based routines. An input file * consists of three different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file. Read the file * INSTALL for further instructions on how to use this file. * dsymm.f PARAMETER ( RCB = 128, CB = 64 ) dsyr2k.f PARAMETER ( RCB = 128, CB = 64 ) dsyrk.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) dtrmm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) dtrsm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) dbigp.f PARAMETER ( DIP41 = 4, DIP42 = 3, $ DIP81 = 4, DIP82 = 3, DIP83 = 4, $ DIP91 = 4, DIP92 = 3, DIP93 = 4 ) dcld.f PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, DP = 8 ) SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' ### GEMM-Based Level 3 BLAS Benchmark ################################## all: tmg timing clean: cleantmg cleantiming tmg: ( cd TMGLIB; $(MAKE) ) timing: ( cd SBENCH; $(MAKE) ) ( cd DBENCH; $(MAKE) ) ( cd CBENCH; $(MAKE) ) ( cd ZBENCH; $(MAKE) ) cleantmg: ( cd TMGLIB; $(MAKE) clean ) cleantiming: ( cd SBENCH; $(MAKE) clean ) ( cd DBENCH; $(MAKE) clean ) ( cd CBENCH; $(MAKE) clean ) ( cd ZBENCH; $(MAKE) clean ) SHAR_EOF fi # end of overwriting check if test ! -d 'SBENCH' then mkdir 'SBENCH' fi cd 'SBENCH' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### GEMM-Based Level 3 BLAS Benchmark #################################### # # The following libraries are specified, a user specified level 3 BLAS # library to be timed (LIB3B), a library with underlying BLAS routines # (LIB12B) where the underlying BLAS routine SGEMM may be specified # separately, and the library with the timing functions SECOND and # DSECND (SSEC). # LIB3B = $(ULIB) SGEMM = $(UULIB) LIB12B = $(UULIB) SSEC = $(UTMG) # # LIB specifies the order in which the libraries are linked with the # benchmark programs. Notice that the built-in GEMM-based routines # will be linked the first SGEMM, level 1 and 2 BLAS routines found # as underlying routines. Change the order in which the libraries are # linked as desired. # LIB = $(SSEC) $(LIB3B) $(SGEMM) $(LIB12B) # ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # SBMFLG : the GEMM-based performance benchmark programs # SPRFLG : routines that print the output results # SGBFLG : the built-in GEMM-based level 3 BLAS routines # SAXFLG : GEMM-based specific auxiliary routines # AXOPT : other auxiliary routines # SBMFLG = $(GBBOPT) SPRFLG = $(AXOPT) SGBFLG = $(GBOPT) SAXFLG = $(GBOPT) AXFLG = $(AXOPT) # ######################################################################## STIMS = sgbtim.f STIM = sgbtim.o SBMS = sgbt01.f sgbt02.f SBM = sgbt01.o sgbt02.o SPRS = sgbtp1.f sgbtp2.f SPR = sgbtp1.o sgbtp2.o SGBS = sgb02.f sgb04.f sgb06.f sgb08.f sgb09.f SGB = sgb02.o sgb04.o sgb06.o sgb08.o sgb09.o SAUXS = sgb90.f sgb91.f SAUX = sgb90.o sgb91.o AUXS = lsame.f xerbla.f AUX = lsame.o xerbla.o SPRMS = ssbpm.f SPRM = ssbpm.o AUXS2 = getwrd.f eoln.f AUX2 = getwrd.o eoln.o OBJ1 = $(STIM) $(SBM) $(SGB) $(SAUX) $(AUX) $(AUX2) $(SPR) OBJ2 = $(SPRM) $(AUX2) ######################################################################## all: sgbtim ssbpm sgbtim: $(OBJ1) $(LOADER) $(LOADOPT) -o sgbtim $(OBJ1) $(LIB) ssbpm: $(OBJ2) $(LOADER) $(LOADOPT) -o ssbpm $(OBJ2) $(STIM): $(STIMS) $(FORTRAN) -c $(SBMFLG) $(STIMS) $(SBM): $(SBMS) $(FORTRAN) -c $(SBMFLG) $(SBMS) $(SPR): $(SPRS) $(FORTRAN) -c $(SPRFLG) $(SPRS) $(SGB): $(SGBS) $(FORTRAN) -c $(SGBFLG) $(SGBS) $(SAUX): $(SAUXS) $(FORTRAN) -c $(SAXFLG) $(SAUXS) $(AUX): $(AUXS) $(FORTRAN) -c $(AXFLG) $(AUXS) $(SPRM): $(SPRMS) $(FORTRAN) -c $(AXFLG) $(SPRMS) $(AUX2): $(AUXS2) $(FORTRAN) -c $(AXFLG) $(AUXS2) clean: rm -f *.o sgbtim ssbpm SHAR_EOF fi # end of overwriting check if test -f 'eoln.f' then echo shar: will not over-write existing file "'eoln.f'" else cat << SHAR_EOF > 'eoln.f' INTEGER FUNCTION EOLN( LN, LLN ) * .. Scalar Arguments .. INTEGER LLN * .. Array Arguments .. CHARACTER LN( LLN ) * * Return the index of the last non-blank character in the last word * (token) of LN. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER IE * .. * .. Executable Statements .. * * Find the end of the last word (token) of LN. * IE = LLN 10 IF( ( LN( IE ).EQ.' ' ).AND.( IE.GE.1 ) )THEN IE = IE - 1 GO TO 10 END IF EOLN = IE * RETURN * * End of EOLN. * END SHAR_EOF fi # end of overwriting check if test -f 'example.in' then echo shar: will not over-write existing file "'example.in'" else cat << SHAR_EOF > 'example.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * Example input file * Single Precision * * * Benchmark results to be presented (parameter TAB): * * 1 The collected benchmark result. * * 2 Performance of the built-in GEMM-Based Level 3 BLAS library * in megaflops. * * 3 Performance of the user-supplied Level 3 BLAS library in * megaflops. * * 4 Performance of the user-supplied SGEMM routine in megaflops. * Problem configurations for SGEMM are chosen to 'correspond' to * those in 2 and 3 for timing purposes, see section 3. * * 5 GEMM-Efficiency of the user-supplied Level 3 routines. * * Performance of a user-supplied * Level 3 BLAS routine (megaflops). * GEMM-Efficiency = ----------------------------------- * Performance of the user-supplied * SGEMM routine (megaflops). * * 6 GEMM-Ratio. * * Performance of the internal GEMM-Based * Level 3 BLAS routine Sxxxx (megaflops). * GEMM-Ratio = ----------------------------------------- * Performance of the user-supplied * Level 3 BLAS routine Sxxxx (megaflops). * *** Label of this test *** LBL Example 1, single precision. *** Benchmark results to be presented *** TAB 1 2 3 4 5 6 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 2 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T DIAG N DIM1 32 64 256 256 DIM2 256 256 32 64 LDA 256 *** Routines to be timed *** SSYMM T SSYRK T SSYR2K T STRMM T STRSM T SHAR_EOF fi # end of overwriting check if test -f 'getwrd.f' then echo shar: will not over-write existing file "'getwrd.f'" else cat << SHAR_EOF > 'getwrd.f' LOGICAL FUNCTION GETWRD( LN, LLN, IB, IE ) * .. Scalar Arguments .. INTEGER LLN, IB, IE * .. Array Arguments .. CHARACTER LN( LLN ) * * Read the first non-blank word from the character string LN. Set * the indices IB and IE to the beginning and end of the word, * respectively. Return .TRUE. if a word was found and .FALSE. if no * word was found. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * .. * .. Executable Statements .. * * Find the beginning of the word. * IB = 1 10 IF( ( LN( IB ).EQ.' ' ).AND.( IB.LT.LLN ) )THEN IB = IB + 1 GO TO 10 END IF * * Find the end of the word. * IE = IB 20 IF( IE.LT.LLN )THEN IF( LN( IE+1 ).NE.' ' )THEN IE = IE + 1 GO TO 20 END IF END IF * * Check if any word was found. * IF( LN( IB ).NE.' ' )THEN GETWRD = .TRUE. ELSE GETWRD = .FALSE. END IF * RETURN * * End of GETWRD. * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'newsgpm.in' then echo shar: will not over-write existing file "'newsgpm.in'" else cat << SHAR_EOF > 'newsgpm.in' * * Example of an input file for the program SSGPM containing user * specified parameters. * * The enclosed program SSGPM re-writes GEMM-Based Level 3 BLAS source * files replacing lines containing old PARAMETER statements for user * specified parameters, with lines containing new PARAMETER statements * given in an input file. The user can conveniently assign new values * to the PARAMETER statements in the input file, and then run SSGPM to * distribute these values to the GEMM-based routines. An input file * consists of three different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file. Read the file * INSTALL for further instructions on how to use this file. * ssymm.f PARAMETER ( RCB = 128, CB = 64 ) ssyr2k.f PARAMETER ( RCB = 128, CB = 64 ) ssyrk.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) strmm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) strsm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) sbigp.f PARAMETER ( SIP41 = 4, SIP42 = 3, $ SIP81 = 4, SIP82 = 3, SIP83 = 4, $ SIP91 = 4, SIP92 = 3, SIP93 = 4 ) scld.f PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, SP = 8 ) SHAR_EOF fi # end of overwriting check if test -f 'sgb02.f' then echo shar: will not over-write existing file "'sgb02.f'" else cat << SHAR_EOF > 'sgb02.f' SUBROUTINE SGB02( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC REAL ALPHA, BETA * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * SGB02 (SSYMM) performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is a symmetric matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the symmetric matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the symmetric matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * symmetric matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * symmetric matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SCOPY * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. User specified parameters for SGB02 .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. REAL T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGB02 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL SGEMM ( 'N', 'N', M, N, 0, ZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by SCOPY is CB. * DO 30, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 20, J = JJ+1, II+ISEC-1 CALL SCOPY ( MIN( JSEC, J-JJ ), A( JJ, J ), 1, $ T1( J-II+1, JJ-II+1 ), RCB ) 20 CONTINUE 30 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, SGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL SGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 80, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 50, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 50 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by SCOPY is CB. * DO 70, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 60, J = II, JJ+JSEC-2 CALL SCOPY ( MIN( JSEC, JJ+JSEC-1-J ), $ A( MAX( JJ, J+1 ), J ), 1, $ T1( J-II+1, MAX( JJ-II+1, J-II+2 ) ), RCB ) 60 CONTINUE 70 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, SGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL SGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF 80 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 120, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 90, J = JJ, JJ+JSEC-1 CALL SCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 90 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by SCOPY is CB. * DO 110, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 100, I = II+1, JJ+JSEC-1 CALL SCOPY ( MIN( ISEC, I-II ), A( II, I ), 1, $ T1( I-JJ+1, II-JJ+1 ), RCB ) 100 CONTINUE 110 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, SGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL SGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF 120 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 160, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL SCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 130 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by SCOPY is CB. * DO 150, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 140, I = JJ, II+ISEC-2 CALL SCOPY ( MIN( ISEC, II+ISEC-1-I ), $ A( MAX( II, I+1 ), I ), 1, $ T1( I-JJ+1, MAX( II-JJ+1, I-JJ+2 ) ), RCB ) 140 CONTINUE 150 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, SGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL SGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 160 CONTINUE END IF END IF * RETURN * * End of SGB02. * END SHAR_EOF fi # end of overwriting check if test -f 'sgb04.f' then echo shar: will not over-write existing file "'sgb04.f'" else cat << SHAR_EOF > 'sgb04.f' SUBROUTINE SGB04( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC REAL ALPHA, BETA * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * SGB04 (SSYRK) performs one of the symmetric rank k operations * * C := alpha*A*A' + beta*C, * * or * * C := alpha*A'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A is an n by k matrix in the first case and a k by n matrix * in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. * * TRANS = 'T' or 't' C := alpha*A'*A + beta*C. * * TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number * of rows of the matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK REAL DELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME, SGB90, SGB91 EXTERNAL LSAME, SGB90, SGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SGEMV, SSYR, SCOPY, SSCAL * .. Parameters .. REAL ONE, ZERO INTEGER SIP41, SIP42 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, $ SIP41 = 41, SIP42 = 42 ) * .. User specified parameters for SGB04 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) * .. Local Arrays .. REAL T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGB04 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL SSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL SSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Upper, Notr. * SMALLN = .NOT.SGB90( SIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.SGB90( SIP42 , N, K ) DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 40, L = 1, K CALL SSYR ( 'U', ISEC, ALPHA, A( II, L ), 1, $ C( II, II ), LDC ) 40 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 50, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 50 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 60, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 60 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having upper * triangular storage format. * DO 70, L = 1, K CALL SSYR ( 'U', ISEC, ALPHA, A( II, L ), 1, $ T2( 1, 1 ), RCB ) 70 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 80, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 80 CONTINUE END IF 90 CONTINUE ELSE DO 130, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 120, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 100, L = LL, LL+LSEC-1 CALL SCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 100 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 110, I = II, II+ISEC-1 CALL SGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 110 CONTINUE DELTA = ONE 120 CONTINUE 130 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Upper, Trans. * SMALLN = .NOT.SGB90( SIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.SGB90( SIP42 , N, K ) DO 220, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 140, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, C( II, I ), 1 ) 140 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 150, L = 1, K CALL SSYR ( 'U', ISEC, ALPHA, A( L, II ), LDA, $ C( II, II ), LDC ) 150 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 160, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 160 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 170, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 170 CONTINUE END IF DO 200, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 180, I = II, II+ISEC-1 CALL SCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 180 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * upper triangular storage format. * DO 190, L = LL, LL+LSEC-1 CALL SSYR ( 'U', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 190 CONTINUE 200 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 210, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 210 CONTINUE END IF 220 CONTINUE ELSE CLDA = SGB91( LDA ) DO 270, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 260, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 230, I = II, II+ISEC-1 CALL SCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 230 CONTINUE ELSE DO 240, L = LL, LL+LSEC-1 CALL SCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 240 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 250, I = II, II+ISEC-1 CALL SGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 250 CONTINUE DELTA = ONE 260 CONTINUE 270 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Lower, Notr. * SMALLN = .NOT.SGB90( SIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.SGB90( SIP42 , N, K ) DO 340, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 280, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 280 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 290, L = 1, K CALL SSYR ( 'L', ISEC, ALPHA, A( II, L ), 1, $ C( II, II ), LDC ) 290 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 300, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 300 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 310, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having lower * triangular storage format. * DO 320, L = 1, K CALL SSYR ( 'L', ISEC, ALPHA, A( II, L ), 1, $ T2( 1, 1 ), RCB ) 320 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 330, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 330 CONTINUE END IF * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 340 CONTINUE ELSE DO 380, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 370, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 350, L = LL, LL+LSEC-1 CALL SCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 350 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 360, I = II, II+ISEC-1 CALL SGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 360 CONTINUE DELTA = ONE 370 CONTINUE * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 380 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Lower, Trans. * SMALLN = .NOT.SGB90( SIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.SGB90( SIP42 , N, K ) DO 470, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 390, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 400, L = 1, K CALL SSYR ( 'L', ISEC, ALPHA, A( L, II ), LDA, $ C( II, II ), LDC ) 400 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 410, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 410 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 420, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 420 CONTINUE END IF DO 450, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 430, I = II, II+ISEC-1 CALL SCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 430 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * lower triangular storage format. * DO 440, L = LL, LL+LSEC-1 CALL SSYR ( 'L', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 440 CONTINUE 450 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 460, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 460 CONTINUE END IF * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 470 CONTINUE ELSE CLDA = SGB91( LDA ) DO 520, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 510, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 480, I = II, II+ISEC-1 CALL SCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 480 CONTINUE ELSE DO 490, L = LL, LL+LSEC-1 CALL SCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 490 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 500, I = II, II+ISEC-1 CALL SGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 500 CONTINUE DELTA = ONE 510 CONTINUE * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 520 CONTINUE END IF END IF END IF * RETURN * * End of SGB04. * END SHAR_EOF fi # end of overwriting check if test -f 'sgb06.f' then echo shar: will not over-write existing file "'sgb06.f'" else cat << SHAR_EOF > 'sgb06.f' SUBROUTINE SGB06( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC REAL ALPHA, BETA * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * SGB06 (SSYR2K) performs one of the symmetric rank 2k operations * * C := alpha*A*B' + alpha*B*A' + beta*C, * * or * * C := alpha*A'*B + alpha*B'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A and B are n by k matrices in the first case and k by n * matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + * beta*C. * * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + * beta*C. * * TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number * of rows of the matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993 * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, JJ, JX, JSEC LOGICAL UPPER, NOTR * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SAXPY, SSCAL * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. User specified parameters for SGB06 .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. REAL T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGB06 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL SSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL SSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Upper, Notr. * DO 70, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL SGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL SAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by SAXPY is CB. * DO 60, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 50, I = JJ, II+ISEC-1 CALL SAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 50 CONTINUE 60 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, BETA, $ C( 1, II ), LDC ) CALL SGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ONE, $ C( 1, II ), LDC ) END IF 70 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Upper, Trans. * DO 120, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A'*B, general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL SGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 80, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, C( II, I ), 1 ) 80 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 90, I = II, II+ISEC-1 CALL SAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 90 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by SAXPY is CB. * DO 110, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 100, I = JJ, II+ISEC-1 CALL SAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 100 CONTINUE 110 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, BETA, $ C( 1, II ), LDC ) CALL SGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( 1, II ), LDA, ONE, $ C( 1, II ), LDC ) END IF 120 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Lower, Notr. * DO 170, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL SGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 130, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 130 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 140, I = II, II+ISEC-1 CALL SAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 140 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by SAXPY is CB. * DO 160, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 150, I = II, JJ+JSEC-1 CALL SAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 150 CONTINUE 160 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL SGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ B( II+ISEC, 1 ), LDB, A( II, 1 ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 170 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Lower, Trans. * DO 220, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL SGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 180, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 180 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 190, I = II, II+ISEC-1 CALL SAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 190 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by SAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 CALL SAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 200 CONTINUE 210 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL SGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ B( 1, II+ISEC ), LDB, A( 1, II ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 220 CONTINUE END IF END IF * RETURN * * End of SGB06. * END SHAR_EOF fi # end of overwriting check if test -f 'sgb08.f' then echo shar: will not over-write existing file "'sgb08.f'" else cat << SHAR_EOF > 'sgb08.f' SUBROUTINE SGB08( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC REAL ALPHA * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * SGB08 (STRMM) performs one of the matrix-matrix operations * * C := alpha*op( A )*C, or C := alpha*C*op( A ), * * where alpha is a scalar, C is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies C from * the left or right as follows: * * SIDE = 'L' or 'l' C := alpha*op( A )*C. * * SIDE = 'R' or 'r' C := alpha*C*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, and on exit is overwritten by the * transformed matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOUNIT, CLDC, SMALLN, $ TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC REAL GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD * .. External Functions .. LOGICAL LSAME, SGB90, SGB91 EXTERNAL LSAME, SGB90, SGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SGEMV, STRMV, SCOPY * .. Parameters .. REAL ZERO, ONE INTEGER SIP81, SIP82, SIP83 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ SIP81 = 81, SIP82 = 82, SIP83 = 83 ) * .. User specified parameters for SGB08 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) REAL T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGB08 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL SGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*C. Left, Upper, No transpose. * SMALLN = .NOT.SGB90( SIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.SGB90( SIP82, M, N ) DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 10, J = 1, N CALL STRMV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * C := T3*C, triangular matrix multiply involving * a upper triangular diagonal block of A stored * in T3. * DO 30, J = 1, N CALL STRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE DELTA = ALPHA CLDC = SGB91( LDC ) DO 110, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in SGEMV that appears if the second * dimension (tsec) is zero. * DO 80, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 110 CONTINUE END IF ELSE * * Form C := alpha*A'*C. Left, Upper, Transpose. * SMALLN = .NOT.SGB90( SIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.SGB90( SIP82, M, N ) DO 150, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'T', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 120, J = 1, N CALL STRMV ( 'U', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A', the transpose of a upper unit or * non-unit triangular diagonal block of A is * copied to the lower triangular part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( I-II+1, 1 ), RCB ) 130 CONTINUE * * C := T3*C, triangular matrix multiply involving * the transpose of a upper triangular diagonal * block of A stored in T3. * DO 140, J = 1, N CALL STRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 150 CONTINUE ELSE DELTA = ALPHA CLDC = SGB91( LDC ) DO 210, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) DO 200, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 160, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 160 CONTINUE ELSE DO 170, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 170 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 180, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( I, I ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( II, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 180 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 190, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 190 CONTINUE 200 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 210 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*C. Left, Lower, No transpose. * SMALLN = .NOT.SGB90( SIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.SGB90( SIP82, M, N ) DO 250, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 220, J = 1, N CALL STRMV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 220 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. * DO 230, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 230 CONTINUE * * C := T3*C, triangular matrix multiply involving * a lower triangular diagonal block of A stored * in T3. * DO 240, J = 1, N CALL STRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 240 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 250 CONTINUE ELSE DELTA = ALPHA CLDC = SGB91( LDC ) DO 320, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 260, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 260 CONTINUE DO 310, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 270, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 280 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in SGEMV that appears if the second * dimension (tsec) is zero. * DO 290, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 290 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 300, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 300 CONTINUE 310 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 320 CONTINUE END IF ELSE * * Form C := alpha*A'*C. Left, Lower, Transpose. * SMALLN = .NOT.SGB90( SIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.SGB90( SIP82, M, N ) DO 360, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'T', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 330, J = 1, N CALL STRMV ( 'L', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 330 CONTINUE ELSE * * T3 := A', the transpose of a lower unit or * non-unit triangular diagonal block of A is * copied to the upper triangular part of T3. * DO 340, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1, I-II+1+OFFD ), RCB ) 340 CONTINUE * * C := alpha*T3*C, triangular matrix multiply * involving the transpose of a lower triangular * diagonal block of A stored in T3. * DO 350, J = 1, N CALL STRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 350 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 360 CONTINUE ELSE DELTA = ALPHA CLDC = SGB91( LDC ) DO 420, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 DO 410, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 370, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 370 CONTINUE ELSE DO 380, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 380 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 390, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( I, I ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, A( I+TIJ, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 390 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 400, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 400 CONTINUE 410 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 420 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*C*A. Right, Upper, No transpose. * TINYM = .NOT.SGB90( SIP83, M, N ) IF( TINYM )THEN DO 440, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 430, I = 1, M CALL STRMV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 430 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 440 CONTINUE ELSE DELTA = ALPHA DO 480, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) DO 470, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 450, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 450 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 460, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 480 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Upper, Transpose. * TINYM = .NOT.SGB90( SIP83, M, N ) IF( TINYM )THEN DO 500, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'T', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A', triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 490, I = 1, M CALL STRMV ( 'U', 'N', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 500 CONTINUE ELSE DELTA = ALPHA DO 550, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 510, J = JJ+OFFD, JJ+JSEC-1 CALL SCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 510 CONTINUE DO 540, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 520, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 520 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 530, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 530 CONTINUE 540 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 550 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*C*A. Right, Lower, No transpose. * TINYM = .NOT.SGB90( SIP83, M, N ) IF( TINYM )THEN DO 570, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * lower triangular diagonal block of A. * DO 560, I = 1, M CALL STRMV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 560 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 570 CONTINUE ELSE DELTA = ALPHA DO 610, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 DO 600, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 580, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 580 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 590, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, C( II, J ), 1 ) 590 CONTINUE 600 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 610 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Lower, Transpose. * TINYM = .NOT.SGB90( SIP83, M, N ) IF( TINYM )THEN DO 630, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'T', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A', triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 620, I = 1, M CALL STRMV ( 'L', 'N', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 620 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 630 CONTINUE ELSE DELTA = ALPHA DO 680, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 640, J = JJ, JJ+JSEC-1-OFFD CALL SCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 640 CONTINUE DO 670, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 650, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 650 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 660, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 660 CONTINUE 670 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 680 CONTINUE END IF END IF END IF END IF * RETURN * * End of SGB08. * END SHAR_EOF fi # end of overwriting check if test -f 'sgb09.f' then echo shar: will not over-write existing file "'sgb09.f'" else cat << SHAR_EOF > 'sgb09.f' SUBROUTINE SGB09( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC REAL ALPHA * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * SGB09 (STRSM) solves one of the matrix equations * * op( A )*X = alpha*C, or X*op( A ) = alpha*C, * * where alpha is a scalar, X and C are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * The matrix X is overwritten on C. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*C. * * SIDE = 'R' or 'r' X*op( A ) = alpha*C. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the right-hand side matrix C, and on exit is * overwritten by the solution matrix X. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOUNIT, CLDC, SMALLN, $ TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC REAL GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD * .. External Functions .. LOGICAL LSAME, SGB90, SGB91 EXTERNAL LSAME, SGB90, SGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SGEMV, STRSV, SCOPY * .. Parameters .. REAL ZERO, ONE INTEGER SIP91, SIP92, SIP93 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ SIP91 = 91, SIP92 = 92, SIP93 = 93 ) * .. User specified parameters for SGB09 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 7, RB = 5, CB = 3 ) REAL T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGB09 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL SGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Upper, No transpose. * SMALLN = .NOT.SGB90( SIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.SGB90( SIP92, M, N ) DO 40, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a upper triangular diagonal block of A. The * block of X is overwritten on C. * DO 10, J = 1, N CALL STRSV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * Solve T3*X = C, triangular system solve * involving a upper triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 30, J = 1, N CALL STRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF 40 CONTINUE ELSE DELTA = ONE CLDC = SGB91( LDC ) DO 110, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 80, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE 110 CONTINUE END IF ELSE * * Solve A'*X = alpha*C. Left, Upper, Transpose. * SMALLN = .NOT.SGB90( SIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.SGB90( SIP92, M, N ) DO 150, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL SGEMM ( 'T', 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C, triangular system solve * involving the transpose of a upper triangular * diagonal block of A. The block of X is * overwritten on C. * DO 120, J = 1, N CALL STRSV ( 'U', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A', the transpose of a upper unit or * non-unit triangular diagonal block of A is * copied to the lower triangular part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( I-II+1, 1 ), RCB ) 130 CONTINUE * * Solve T3*X = C, triangular system solve * involving the transpose of a upper triangular * diagonal block of A stored in T3. The block of X * is overwritten on C. * DO 140, J = 1, N CALL STRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF 150 CONTINUE ELSE DELTA = ONE CLDC = SGB91( LDC ) DO 210, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL SGEMM ( 'T', 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) DO 200, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 160, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 160 CONTINUE ELSE DO 170, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 170 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 180, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/A( I, I ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( II, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 180 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 190, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 190 CONTINUE 200 CONTINUE 210 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Lower, No transpose. * SMALLN = .NOT.SGB90( SIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.SGB90( SIP92, M, N ) DO 250, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL SGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a lower triangular diagonal block of A. The * block of X is overwritten on C. * DO 220, J = 1, N CALL STRSV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 220 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. The block of X is * overwritten on C. * DO 230, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 230 CONTINUE * * Solve T3*X = C, triangular system solve * involving a lower triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 240, J = 1, N CALL STRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 240 CONTINUE END IF 250 CONTINUE ELSE DELTA = ONE CLDC = SGB91( LDC ) DO 320, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL SGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 260, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 260 CONTINUE DO 310, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 270, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 280 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 290, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 290 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 300, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 300 CONTINUE 310 CONTINUE 320 CONTINUE END IF ELSE * * Solve A'*X = alpha*C. Left, Lower, Transpose. * SMALLN = .NOT.SGB90( SIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.SGB90( SIP92, M, N ) DO 360, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C, triangular system solve * involving the transpose of a lower triangular * diagonal block of A. The block of X is * overwritten on C. * DO 330, J = 1, N CALL STRSV ( 'L', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 330 CONTINUE ELSE * * T3 := A', the transpose of a lower unit or * non-unit triangular diagonal block of A is * copied to the upper triangular part of T3. * DO 340, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1, I-II+1+OFFD ), RCB ) 340 CONTINUE * * Solve T3*X = C, triangular system solve * involving the transpose of a lower triangular * diagonal block of A stored in T3. The block of X * is overwritten on C. * DO 350, J = 1, N CALL STRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 350 CONTINUE END IF 360 CONTINUE ELSE DELTA = ONE CLDC = SGB91( LDC ) DO 420, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) DO 410, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 370, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 370 CONTINUE ELSE DO 380, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 380 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 390, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/A( I, I ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, A( I+TIJ, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 390 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 400, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 400 CONTINUE 410 CONTINUE 420 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Upper, No transpose. * TINYM = .NOT.SGB90( SIP93, M, N ) IF( TINYM )THEN DO 440, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a upper triangular diagonal block of A. The block * of X is overwritten on C. * DO 430, I = 1, M CALL STRSV ( 'U', 'T', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 430 CONTINUE 440 CONTINUE ELSE DELTA = ONE DO 490, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 480, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 450, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 450 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 460, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 460 CONTINUE * * C := T1, T1 is copied back to C. * DO 470, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 470 CONTINUE 480 CONTINUE 490 CONTINUE END IF ELSE * * Solve X*A' = alpha*C. Right, Upper, Transpose. * TINYM = .NOT.SGB90( SIP93, M, N ) IF( TINYM )THEN DO 510, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A' = C, triangular system solve involving * the transpose of a upper triangular diagonal block * of A. The block of X is overwritten on C. * DO 500, I = 1, M CALL STRSV ( 'U', 'N', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 500 CONTINUE 510 CONTINUE ELSE DELTA = ONE DO 570, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 520, J = JJ+OFFD, JJ+JSEC-1 CALL SCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 520 CONTINUE DO 560, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 530, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 530 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 540, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 540 CONTINUE * * C := T1, T1 is copied back to C. * DO 550, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 550 CONTINUE 560 CONTINUE 570 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Lower, No transpose. * TINYM = .NOT.SGB90( SIP93, M, N ) IF( TINYM )THEN DO 590, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a lower triangular diagonal block of A. The block * of X is overwritten on C. * DO 580, I = 1, M CALL STRSV ( 'L', 'T', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 580 CONTINUE 590 CONTINUE ELSE DELTA = ONE DO 640, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 630, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 600, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 600 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 610, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 610 CONTINUE * * C := T1, T1 is copied back to C. * DO 620, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 620 CONTINUE 630 CONTINUE 640 CONTINUE END IF ELSE * * Solve X*A' = alpha*C. Right, Lower, Transpose. * TINYM = .NOT.SGB90( SIP93, M, N ) IF( TINYM )THEN DO 660, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A' = C, triangular system solve involving * the transpose of a lower triangular diagonal block * of A. The block of X is overwritten on C. * DO 650, I = 1, M CALL STRSV ( 'L', 'N', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 650 CONTINUE 660 CONTINUE ELSE DELTA = ONE DO 720, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 670, J = JJ, JJ+JSEC-1-OFFD CALL SCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 670 CONTINUE DO 710, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 680, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 680 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 690, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 690 CONTINUE * * C := T1, T1 is copied back to C. * DO 700, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 700 CONTINUE 710 CONTINUE 720 CONTINUE END IF END IF END IF END IF * RETURN * * End of SGB09. * END SHAR_EOF fi # end of overwriting check if test -f 'sgb90.f' then echo shar: will not over-write existing file "'sgb90.f'" else cat << SHAR_EOF > 'sgb90.f' LOGICAL FUNCTION SGB90( IP, DIM1, DIM2 ) * .. Scalar Arguments .. INTEGER IP, DIM1, DIM2 * .. * * Purpose * ======= * * SGB90 determines which of two alternative code sections in a GEMM- * Based Level 3 BLAS routine that will be the fastest for a particular * problem. If the problem is considered large enough SGB90 returns * .TRUE., otherwise .FALSE. is returned. The input parameter IP * specifies the calling routine and a break point for alternative code * sections. The input parameters DIM1 and DIM2 are matrix dimensions. * The returned value is a function of the input parameters and the * performance characteristics of the two alternative code sections. * * In this simple implementation, the returned values are determined by * looking at only one of the two dimensions DIM1 and DIM2. It may be * rewarding to rewrite the logical expressions in SGB90 so that both * dimensions are involved. The returned values should effectively * reflect the performance characteristics of the underlying BLAS * routines. * * * Input * ===== * * IP - INTEGER * On entry, IP specifies which routine and which alternative * code sections that the decision is intended for. * Unchanged on exit. * * DIM1 - INTEGER. * On entry, DIM1 specifies the first dimension in the calling * sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * DIM2 - INTEGER. * On entry, DIM2 specifies the second dimension in the * calling sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. User specified parameters for SGB90 .. INTEGER SIP41, SIP42, SIP81, SIP82, SIP83, $ SIP91, SIP92, SIP93 PARAMETER ( SIP41 = 4, SIP42 = 3, $ SIP81 = 4, SIP82 = 3, SIP83 = 4, $ SIP91 = 4, SIP92 = 3, SIP93 = 4 ) * .. * .. Executable Statements .. IF( IP.EQ.41 )THEN SGB90 = DIM1.GE.SIP41 ELSE IF( IP.EQ.42 )THEN SGB90 = DIM2.GE.SIP42 ELSE IF( IP.EQ.81 )THEN SGB90 = DIM2.GE.SIP81 ELSE IF( IP.EQ.82 )THEN SGB90 = DIM2.GE.SIP82 ELSE IF( IP.EQ.83 )THEN SGB90 = DIM1.GE.SIP83 ELSE IF( IP.EQ.91 )THEN SGB90 = DIM2.GE.SIP91 ELSE IF( IP.EQ.92 )THEN SGB90 = DIM2.GE.SIP92 ELSE IF( IP.EQ.93 )THEN SGB90 = DIM1.GE.SIP93 ELSE SGB90 = .FALSE. END IF * RETURN * * End of SGB90. * END SHAR_EOF fi # end of overwriting check if test -f 'sgb91.f' then echo shar: will not over-write existing file "'sgb91.f'" else cat << SHAR_EOF > 'sgb91.f' LOGICAL FUNCTION SGB91( LD ) * .. Scalar Arguments .. INTEGER LD * .. * * Purpose * ======= * * The size of the leading dimension of a two-dimensional array may * cause severe problems. Often when an array with a 'critical' leading * dimension is referenced, the execution time becomes significantly * longer than expected. This is caused by shortcomings of the memory * system. * * The function SGB91 returns .TRUE. if the leading dimension LD is * critical and .FALSE. if it is not critical. In this implementation * SGB91 is designed to detect critical leading dimensions in an * environment with a multi-way associative cache. Parameters defining * cache characteristics are adjustable to match different machines. * It may be rewarding to rewrite SGB91 for a machine with a different * cache policy. * * The cache lines in a multi-way associative cache are divided among a * number of partitions, each containing the same number of lines. Each * address of main memory is mapped into a particular partition. The * number of lines in a partition equals the associativity. For example, * in a four way associative cache, each partition contain four cache * lines. * * Data are transferred between the cache and main memory according to * an associative mapping scheme. A transfer of a data word from main * memory to cache is accomplished as follows. A unit of data * (data line) in main memory, with the size of a cache line, and * containing several contiguous data words including the referenced * one, is mapped (copied) to a certain partition in the cache memory. * The partition is determined by the location of the element in the * main memory and the associative mapping scheme. A replacement * algorithm makes room for the data line in one of the cache lines in * the selected partition. For example, an LRU-based (Least Recently * Used) replacement algorithm places the data line in the least * recently 'touched' cache line in the selected partition. * * * Input * ===== * * LD - On entry, LD specifies the leading dimension of a * 2-dimensional array. Unchanged on exit. * * * User specified parameters for SGB91 * ================================ * * LNSZ - Size of a cache line in number of bytes. * * NPRT - Number of partitions in the cache memory. * * PRTSZ - The number of cache lines in a partition that can be used * exclusively to hold a local array containing a matrix block * during the execution of a GEMM-Based Level 3 BLAS routine. * The remaining cache lines may be occupied by scalars, * vectors and possibly program code depending on the system. * * LOLIM - Leading dimensions smaller than or equal to LOLIM are not * considered critical. * * SP - Number of bytes in a single-precision word. * * * Local Variables and Parameters * ============================== * * ONEWAY - The maximum number of real words that can be * stored in the cache memory if only a single cache line in * each partition may be used. * * UPDIF - The difference between the multiple of LD that is nearest * ONEWAY, or nearest a multiple of ONEWAY, and the nearest * multiple of ONEWAY that is larger than LD. In number of * real words. * * MXDIF - If both UPDIF and LD - UPDIF are less than MXDIF, and LD * is greater than LOLIM, then the leading dimension is * considered critical. Otherwise, the leading dimension is * considered not critical. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Variables .. INTEGER UPDIF * .. Intrinsic Functions .. INTRINSIC MIN, MOD * .. User specified parameters for SGB91 .. INTEGER LOLIM, LNSZ, NPRT, PRTSZ, SP PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, SP = 8 ) * .. Parameters .. INTEGER ONEWAY, MXDIF PARAMETER ( ONEWAY = ( LNSZ*NPRT )/SP, $ MXDIF = LNSZ/( SP*PRTSZ ) ) * .. * .. Executable Statements .. * IF( LD.LE.LOLIM )THEN SGB91 = .FALSE. ELSE UPDIF = MOD( ( LD/ONEWAY )*ONEWAY+ONEWAY, LD ) SGB91 = MIN( UPDIF, LD-UPDIF ).LE.MXDIF END IF * RETURN * * End of SGB91. * END SHAR_EOF fi # end of overwriting check if test -f 'sgbt01.f' then echo shar: will not over-write existing file "'sgbt01.f'" else cat << SHAR_EOF > 'sgbt01.f' SUBROUTINE SGBT01( SB3LIB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXDIM, MXLDA, RUNS, RES ) * .. Scalar Arguments .. CHARACTER SB3LIB INTEGER LD, NMAX, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXDIM, MXLDA, RUNS REAL ALPHA, BETA * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXOPT ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) REAL A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ), $ RES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, MXDIM, $ MXLDA ) * * * Time all routines except SGEMM in the Level 3 BLAS library specified * by the input parameters. The library is either a user-supplied * Level 3 BLAS library or the GEMM-Based Level 3 BLAS library included * in the benchmark (SGB02, SGB04, SGB06, SGB08, and SGB09). Return the * performance in Mflops for each problem configuration. * * SGBT01 calls a REAL function SECOND with no arguments, * which is assumed to return the user time for a process in seconds * from some fixed starting-time. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, J, M, N, K, NOPS, $ D, L, R, OP1, OP2, OP3, OP4 REAL TIME, SPEED, TM0, TM1, TM2, TM3, TM4, TM5, TM6, $ TM7, TM8, TM9, TM10, TM11 * .. Intrinsic Functions .. INTRINSIC REAL, MIN * .. External Functions .. LOGICAL LSAME REAL SECOND EXTERNAL LSAME, SECOND * .. External Subroutines .. EXTERNAL SSYMM, SSYRK, SSYR2K, STRMM, STRSM, $ SGB02, SGB04, SGB06, SGB08, SGB09 * .. Parameters .. REAL ZERO, ONE, SCALE * .. Parameter Values .. PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, SCALE = 1.0E+6 ) * .. * .. Executable Statements .. TM0 = SECOND( ) TM0 = SECOND( ) TM0 = SECOND( ) TM1 = SECOND( ) * * ------ Stop indentation ------ * DO 270, L = 1, NLDA DO 260, OP1 = 1, NSIDE DO 250, OP2 = 1, NUPLO DO 240, OP3 = 1, NTRNS DO 230, OP4 = 1, NDIAG DO 220, D = 1, NDIM * * ------ Continue indentation ------ * RES( 1, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 2, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 3, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 4, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 5, OP1, OP2, OP3, OP4, D, L ) = ZERO DO 210, R = 1, RUNS IF( LSAME( SB3LIB, 'U' ) )THEN * * Time the user-supplied library. Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 20, J = 1, NMAX DO 10, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 10 CONTINUE 20 CONTINUE TM2 = SECOND( ) CALL SSYMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM3 = SECOND( ) END IF IF( TABSUB( 2 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN DO 40, J = 1, NMAX DO 30, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 30 CONTINUE 40 CONTINUE TM4 = SECOND( ) CALL SSYRK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), $ BETA, C, LDA( L ) ) TM5 = SECOND( ) END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN DO 60, J = 1, NMAX DO 50, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 50 CONTINUE 60 CONTINUE TM6 = SECOND( ) CALL SSYR2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM7 = SECOND( ) END IF IF( TABSUB( 4 ) )THEN DO 80, J = 1, NMAX DO 70, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 70 CONTINUE 80 CONTINUE TM8 = SECOND( ) CALL STRMM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM9 = SECOND( ) END IF IF( TABSUB( 5 ) )THEN DO 100, J = 1, NMAX DO 90, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 90 CONTINUE 100 CONTINUE TM10 = SECOND( ) CALL STRSM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM11 = SECOND( ) END IF ELSE IF( LSAME( SB3LIB, 'G' ) )THEN * * Time the built-in GEMM-Based Level 3 BLAS library (SGB02, * SGB04, SGB06, SGB08, and SGB09). Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 120, J = 1, NMAX DO 110, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 110 CONTINUE 120 CONTINUE TM2 = SECOND( ) CALL SGB02( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM3 = SECOND( ) END IF IF( TABSUB( 2 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN DO 140, J = 1, NMAX DO 130, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 130 CONTINUE 140 CONTINUE TM4 = SECOND( ) CALL SGB04( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), $ BETA, C, LDA( L ) ) TM5 = SECOND( ) END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN DO 160, J = 1, NMAX DO 150, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 150 CONTINUE 160 CONTINUE TM6 = SECOND( ) CALL SGB06( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM7 = SECOND( ) END IF IF( TABSUB( 4 ) )THEN DO 180, J = 1, NMAX DO 170, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 170 CONTINUE 180 CONTINUE TM8 = SECOND( ) CALL SGB08( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM9 = SECOND( ) END IF IF( TABSUB( 5 ) )THEN DO 200, J = 1, NMAX DO 190, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 190 CONTINUE 200 CONTINUE TM10 = SECOND( ) CALL SGB09( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM11 = SECOND( ) END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown Level 3 BLAS library choosen: ', SB3LIB, '.' END IF * * Compute the performance of SSYMM in Mflops. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM3 - TM2 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN NOPS = ( 2*M + 1 )*M*N + MIN( M*N, ( M*( M+1 ) )/2 ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN NOPS = ( 2*N + 1 )*M*N + MIN( M*N, ( N*( N+1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 1, OP1, OP2, 1, 1, D, L ).LT.SPEED )THEN RES( 1, OP1, OP2, 1, 1, D, L ) = SPEED END IF END IF * * Compute the performance of SSYRK in Mflops. * IF( TABSUB( 2 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM5 - TM4 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( 2*K + 1 )*( N*( N+1 )/2 ) + MIN( N*K, N*( N+1 )/2 ) IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 2, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 2, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of SSYR2K in Mflops. * IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM7 - TM6 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( 4*K + 1 )*( N*( N+1 )/2 ) + MIN( 2*N*K, N*( N+1 ) ) IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 3, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 3, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of STRMM in Mflops. * IF( TABSUB( 4 ) )THEN TIME = ( TM9 - TM8 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN NOPS = M*M*N + MIN( M*N, ( M*( M + 1 ) )/2 ) ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN NOPS = M*M*N - M*N + MIN( M*N, ( M*( M + 1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN NOPS = M*N*N + MIN( M*N, ( N*( N + 1 ) )/2 ) ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN NOPS = M*N*N - M*N + MIN( M*N, ( N*( N + 1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 4, OP1, OP2, OP3, OP4, D, L ).LT.SPEED )THEN RES( 4, OP1, OP2, OP3, OP4, D, L ) = SPEED END IF END IF * * Compute the performance of STRSM in Mflops. * IF( TABSUB( 5 ) )THEN TIME = ( TM11 - TM10 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN NOPS = M*M*N + MIN( M*N, ( M*( M + 1 ) )/2 ) ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN NOPS = M*M*N - M*N + MIN( M*N, ( M*( M + 1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN NOPS = M*N*N + MIN( M*N, ( N*( N + 1 ) )/2 ) ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN NOPS = M*N*N - M*N + MIN( M*N, ( N*( N + 1 ) )/2 ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 5, OP1, OP2, OP3, OP4, D, L ).LT.SPEED )THEN RES( 5, OP1, OP2, OP3, OP4, D, L ) = SPEED END IF END IF 210 CONTINUE * * ------ Stop indentation ------ * 220 CONTINUE 230 CONTINUE 240 CONTINUE 250 CONTINUE 260 CONTINUE 270 CONTINUE * * ------ Continue indentation ------ * RETURN * * End of SGBT01. * END SHAR_EOF fi # end of overwriting check if test -f 'sgbt02.f' then echo shar: will not over-write existing file "'sgbt02.f'" else cat << SHAR_EOF > 'sgbt02.f' SUBROUTINE SGBT02( TABSUB, SIDE, NSIDE, NUPLO, TRNS, NTRNS, NDIAG, $ DIM1, DIM2, NDIM, LDA, NLDA, ALPHA, BETA, $ A, B, C, LD, NMAX, NERR, MXSUB, MXOPT, $ MXDIM, MXLDA, RUNS, RES ) * .. Scalar Arguments .. INTEGER LD, NMAX, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXDIM, MXLDA, RUNS REAL ALPHA, BETA * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER SIDE( MXOPT ), TRNS( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) REAL A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ), $ RES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, MXDIM, $ MXLDA ) * * * Determine problem configurations for SGEMM that, for timing purposes, * "correspond" to problem configurations for the remaining Level 3 BLAS * routines. Time SGEMM for problems that correspond to the Level 3 BLAS * problems timed in SGBT01. Return the performance of SGEMM in Mflops. * * SGBT02 calls a REAL function SECOND with no arguments, * which is assumed to return the user time for a process in seconds * from some fixed starting-time. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, J, M, N, K, NOPS, $ D, L, R, OP1, OP2, OP3, OP4 REAL TIME, SPEED, TM0, TM1, TM2, TM3, TM4, TM5, TM6, $ TM7, TM8, TM9 * .. Intrinsic Functions .. INTRINSIC REAL, MIN * .. External Functions .. LOGICAL LSAME REAL SECOND EXTERNAL LSAME, SECOND * .. External Subroutines .. EXTERNAL SGEMM * .. Parameters .. REAL ZERO, ONE, SCALE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, SCALE = 1.0E+6 ) * .. * .. Executable Statements .. TM0 = SECOND( ) TM0 = SECOND( ) TM0 = SECOND( ) TM1 = SECOND( ) * * ------ Stop indentation ------ * DO 180, L = 1, NLDA DO 170, OP1 = 1, NSIDE DO 160, OP3 = 1, NTRNS DO 150, D = 1, NDIM * * ------ Continue indentation ------ * RES( 1, OP1, 1, OP3, 1, D, L ) = ZERO RES( 2, OP1, 1, OP3, 1, D, L ) = ZERO RES( 3, OP1, 1, OP3, 1, D, L ) = ZERO RES( 4, OP1, 1, OP3, 1, D, L ) = ZERO RES( 5, OP1, 1, OP3, 1, D, L ) = ZERO DO 140, R = 1, RUNS * * Time the user-supplied library. Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1 )THEN DO 20, J = 1, NMAX DO 10, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 10 CONTINUE 20 CONTINUE * * Time SGEMM for a problem that corresponds to the following * problem for SSYMM: * SSYMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) * IF( LSAME( SIDE( OP1 ), 'L' ) )THEN * * Use K = M. * TM2 = SECOND( ) CALL SGEMM( 'N', 'N', DIM1( D ), DIM2( D ), DIM1( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM3 = SECOND( ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN * * Use K = N. * TM2 = SECOND( ) CALL SGEMM( 'N', 'N', DIM1( D ), DIM2( D ), DIM2( D ), $ ALPHA, B, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM3 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' STOP END IF END IF IF( TABSUB( 2 ).AND.OP1.EQ.1 )THEN DO 40, J = 1, NMAX DO 30, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 30 CONTINUE 40 CONTINUE * * Time SGEMM for a problem that corresponds to the following * problem for SSYRK: * SSYRK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), BETA, C, LDA( L ) ) * Use M = N and B = A in the call to SGEMM. * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM4 = SECOND( ) CALL SGEMM( 'N', 'T', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM5 = SECOND( ) ELSE IF( LSAME( TRNS( OP3 ), 'T' ) )THEN TM4 = SECOND( ) CALL SGEMM( 'T', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM5 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 3 ).AND.OP1.EQ.1 )THEN DO 60, J = 1, NMAX DO 50, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 50 CONTINUE 60 CONTINUE * * Time SGEMM for a problem that corresponds to the following * problem for SSYR2K: * SSYR2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM6 = SECOND( ) CALL SGEMM( 'N', 'T', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM7 = SECOND( ) ELSE IF( LSAME( TRNS( OP3 ), 'T' ) )THEN TM6 = SECOND( ) CALL SGEMM( 'T', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM7 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 4 ).OR.TABSUB( 5 ) )THEN DO 80, J = 1, NMAX DO 70, I = 1, LD C( I, J ) = ONE + 0.01E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( LD*NMAX+1 ) 70 CONTINUE 80 CONTINUE * * Time SGEMM for a problem that corresponds to the following * problems for STRMM and STRSM: * STRMM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), * DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, * A, LDA( L ), C, LDA( L ) ) * STRSM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), * DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, * A, LDA( L ), C, LDA( L ) ) * IF( LSAME( SIDE( OP1 ), 'L' ) )THEN * * C := alpha*A*C + C or C := alpha*A'*C + C. Use K = M. * TM8 = SECOND( ) CALL SGEMM( TRNS( OP3 ), 'N', DIM1( D ), DIM2( D ), $ DIM1( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ ONE, C, LDA( L ) ) TM9 = SECOND( ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN * * C := alpha*C*A + C or C := alpha*C*A' + C. Use K = N. * TM8 = SECOND( ) CALL SGEMM( 'N', TRNS( OP3 ), DIM1( D ), DIM2( D ), $ DIM2( D ), ALPHA, B, LDA( L ), A, LDA( L ), $ ONE, C, LDA( L ) ) TM9 = SECOND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' STOP END IF END IF * * Compute the performance of SGEMM in Mflops for problem * configurations that corresponds to SSYMM. * IF( TABSUB( 1 ).AND.OP3.EQ.1 )THEN TIME = ( TM3 - TM2 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN NOPS = ( 2*M + 1 )*M*N + MIN( M*N, M*M ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN NOPS = ( 2*N + 1 )*M*N + MIN( M*N, N*N ) END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 1, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 90, OP2 = 1, NUPLO RES( 1, OP1, OP2, OP3, 1, D, L ) = SPEED 90 CONTINUE END IF END IF * * Compute the performance of SGEMM in Mflops for problem * configurations that corresponds to SSYRK. * IF( TABSUB( 2 ).AND.OP1.EQ.1 )THEN TIME = ( TM5 - TM4 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( 2*K + 1 )*N*N + MIN( N*K, N*N ) IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 2, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 100, OP2 = 1, NUPLO RES( 2, OP1, OP2, OP3, 1, D, L ) = SPEED 100 CONTINUE END IF END IF * * Compute the performance of SGEMM in Mflops for problem * configurations that corresponds to SSYR2K. * IF( TABSUB( 3 ).AND.OP1.EQ.1 )THEN TIME = ( TM7 - TM6 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( 2*K + 1 )*N*N + MIN( N*K, N*N ) IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 3, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 110, OP2 = 1, NUPLO RES( 3, OP1, OP2, OP3, 1, D, L ) = SPEED 110 CONTINUE END IF END IF * * Compute the performance of SGEMM in Mflops for problem * configurations that corresponds to STRMM and STRSM. * IF( TABSUB( 4 ).OR.TABSUB( 5 ) )THEN TIME = ( TM9 - TM8 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN NOPS = ( 2*M - 1 )*M*N + MIN( M*N, M*M ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN NOPS = ( 2*N - 1 )*M*N + MIN( M*N, N*N ) END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = REAL( NOPS )/( TIME*SCALE ) END IF IF( RES( 4, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 130, OP2 = 1, NUPLO DO 120, OP4 = 1, NDIAG RES( 4, OP1, OP2, OP3, OP4, D, L ) = SPEED RES( 5, OP1, OP2, OP3, OP4, D, L ) = SPEED 120 CONTINUE 130 CONTINUE END IF END IF 140 CONTINUE * * ------ Stop indentation ------ * 150 CONTINUE 160 CONTINUE 170 CONTINUE 180 CONTINUE * * ------ Continue indentation ------ * RETURN * * End of SGBT02. * END SHAR_EOF fi # end of overwriting check if test -f 'sgbtim.f' then echo shar: will not over-write existing file "'sgbtim.f'" else cat << SHAR_EOF > 'sgbtim.f' * * GEMM-Based Level 3 BLAS Benchmark * REAL * * The GEMM-Based Level 3 BLAS Benchmark is a tool for performance * evaluation of Level 3 BLAS kernel programs. With the announcement of * LAPACK, the need for high performance Level 3 BLAS kernels became * apparent. LAPACK is based on calls to the Level 3 BLAS kernels. This * benchmark measures and compares performance of a set of user supplied * Level 3 BLAS implementations and of the GEMM-Based Level 3 BLAS * implementations permanently included in the benchmark. The purpose of * the benchmark is to facilitate the user in determining the quality of * different Level 3 BLAS implementations. The included GEMM-Based * Level 3 BLAS routines provide a lower limit on the performance to be * expected from a highly optimized Level 3 BLAS library. * * All routines are written in Fortran 77 for portability. No changes to * the code should be necessary in order to run the programs correctly * on different target machines. In fact, we strongly recommend the user * to avoided changes, except to the user specified parameters and to * UNIT numbers for input and output communication. This will ensure * that performance results from different target machines are * comparable. * * The program calls a REAL function SECOND with no * arguments, which is assumed to return the user time for a process in * seconds from some fixed starting-time. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * PROGRAM SGBTIM * .. Parameters .. INTEGER NIN, NOUT, NERR, IERR PARAMETER ( NIN = 5, NOUT = 6, NERR = 6 ) INTEGER LD, NMAX PARAMETER ( LD = 530, NMAX = LD ) INTEGER LLN, LST, LNM PARAMETER ( LLN = 256, LST = 50, LNM = 6 ) INTEGER MXTAB, MXOPT, MXDIM, MXLDA, MXSUB, MXRUNS PARAMETER ( MXTAB = 6, MXSUB = 5, MXOPT = 2, MXDIM = 36, $ MXLDA = 24, MXRUNS = 20 ) REAL ONE, ALPHA, BETA PARAMETER ( ONE = 1.0E+0, ALPHA = 0.9E+0, BETA = 1.1E+0 ) * .. Local Scalars .. INTEGER I, IB, IE, IX, J, JB, JE, KB, KE, $ NTAB, NSIDE, NUPLO, NTRNS, NDIAG, NDIM1, NDIM2, $ NLDA, NRUNS, RUNS, MATCH LOGICAL ERR1, ERR2, ERR3, ERR4, SUB * .. Intrinsic Functions .. INTRINSIC REAL * .. External Functions .. INTEGER EOLN LOGICAL LSAME, GETWRD EXTERNAL LSAME, GETWRD, EOLN * .. External Subroutines .. EXTERNAL SGBT01, SGBT02, SGBTP1, SGBTP2 * .. Local Arrays .. INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) LOGICAL SUBCHK( MXSUB ), TABSUB( MXSUB ), TAB( MXTAB ) REAL A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ), $ USRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ GBRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ) COMMON / SBKCMN / A, B, C, USRES, GBRES, MMRES CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXOPT ), $ DIAG( MXOPT ) CHARACTER INLN*( LLN ), INSTR*( LST ), BLANK*( LST ), $ LBL*( LST ), NAME( MXSUB )*( LNM ) CHARACTER INLNA( LLN ) EQUIVALENCE ( INLN, INLNA ) * .. Data statements .. DATA NTAB/ 0 /, NRUNS/ 0 /, NSIDE/ 0 /, NUPLO/ 0 /, $ NTRNS/ 0 /, NDIAG/ 0 /, NDIM1/ 0 /, NDIM2/ 0 /, $ NLDA/ 0 / DATA TAB/ MXTAB*.FALSE. /, TABSUB/ MXSUB*.FALSE. /, $ SUBCHK/ MXSUB*.FALSE. /, $ SIDE/ MXOPT*' ' /, UPLO/ MXOPT*' '/, $ TRNS/ MXOPT*' ' /, DIAG/ MXOPT*' '/, $ NAME/ 'SSYMM ', 'SSYRK ', 'SSYR2K', 'STRMM ', $ 'STRSM '/, SUB/ .FALSE. / DATA BLANK/' '/, $ LBL /' '/ * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. Store the line in the variable INLN. The first word (token) * of the line is stored in INLN( IB:IE ). * 10 READ( NIN, FMT = 9000, END = 200 ) INLN IF( .NOT.GETWRD( INLNA, LLN, IB, IE ).OR. $ ( INLN( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * If INLN( IB:IE ) contains the key word for a parameter, then read * and store the parameter values given on the same line of the input * file, after the key word. * JB = IB JE = IE I = 0 ERR1 = .FALSE. ERR2 = .FALSE. ERR3 = .FALSE. ERR4 = .FALSE. * * Read the parameters from the line INLN. * IF( INLN( JB:JE ).EQ.'LBL' )THEN * * Read the label of this test. * IF( LBL.NE.BLANK )THEN ERR3 = .TRUE. END IF IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN KE = EOLN( INLNA( JE+1 ), LLN-JE-1 ) JB = JE + KB JE = JE + KE IF( JE-JB+1.GT.LST )THEN ERR4 = .TRUE. ELSE LBL = INLN( JB:JE ) END IF END IF I = 1 ELSE IF( INLN( JB:JE ).EQ.'TAB' )THEN * * Read which tests to be made. * IF( NTAB.NE.0 )THEN ERR3 = .TRUE. END IF 20 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXTAB )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) IX IF( IERR.GT.0.OR.IX.LT.1.OR.IX.GT.MXTAB )THEN ERR1 = .TRUE. END IF IF( TAB( IX ) )THEN ERR1 = .TRUE. END IF TAB( IX ) = .TRUE. ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 20 END IF END IF NTAB = I ELSE IF( INLN( JB:JE ).EQ.'RUNS' )THEN * * Read the number of times each problem is to be executed. The * final performance results are computed using the best timing * result for each problem. * IF( NRUNS.NE.0 )THEN ERR3 = .TRUE. END IF 30 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.1 )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) RUNS IF( IERR.GT.0.OR.RUNS.LT.1.OR.RUNS.GT.MXRUNS )THEN ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 30 END IF END IF NRUNS = I ELSE IF( INLN( IB:IE ).EQ.'SIDE' )THEN * * Read the values for SIDE. * IF( NSIDE.NE.0 )THEN ERR3 = .TRUE. END IF 40 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'L' ) )THEN DO 50, J = 1, I IF( LSAME( SIDE( J ), 'L' ) ) ERR1 = .TRUE. 50 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'R' ) )THEN DO 60, J = 1, I IF( LSAME( SIDE( J ), 'R' ) ) ERR1 = .TRUE. 60 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 SIDE( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 40 END IF END IF NSIDE = I ELSE IF( INLN( IB:IE ).EQ.'UPLO' )THEN * * Read the values for UPLO. * IF( NUPLO.NE.0 )THEN ERR3 = .TRUE. END IF 70 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'U' ) )THEN DO 80, J = 1, I IF( LSAME( UPLO( J ), 'U' ) ) ERR1 = .TRUE. 80 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'L' ) )THEN DO 90, J = 1, I IF( LSAME( UPLO( J ), 'L' ) ) ERR1 = .TRUE. 90 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 UPLO( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 70 END IF END IF NUPLO = I ELSE IF( INLN( IB:IE ).EQ.'TRANS' )THEN * * Read the values for TRANS. * IF( NTRNS.NE.0 )THEN ERR3 = .TRUE. END IF 100 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'N' ) )THEN DO 110, J = 1, I IF( LSAME( TRNS( J ), 'N' ) ) ERR1 = .TRUE. 110 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'T' ) )THEN DO 120, J = 1, I IF( LSAME( TRNS( J ), 'T' ) ) ERR1 = .TRUE. 120 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 TRNS( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 100 END IF END IF NTRNS = I ELSE IF( INLN( IB:IE ).EQ.'DIAG' )THEN * * Read the values for DIAG. * IF( NDIAG.NE.0 )THEN ERR3 = .TRUE. END IF 130 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'N' ) )THEN DO 140, J = 1, I IF( LSAME( DIAG( J ), 'N' ) ) ERR1 = .TRUE. 140 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'U' ) )THEN DO 150, J = 1, I IF( LSAME( DIAG( J ), 'U' ) ) ERR1 = .TRUE. 150 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 DIAG( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 130 END IF END IF NDIAG = I ELSE IF( INLN( IB:IE ).EQ.'DIM1' )THEN * * Read the values for the first matrix dimension (DIM1). * IF( NDIM1.NE.0 )THEN ERR3 = .TRUE. END IF 160 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXDIM )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) DIM1( I ) IF( IERR.GT.0.OR.DIM1( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( DIM1( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 160 END IF END IF NDIM1 = I ELSE IF( INLN( IB:IE ).EQ.'DIM2' )THEN * * Read the values for the second matrix dimension (DIM2). * IF( NDIM2.NE.0 )THEN ERR3 = .TRUE. END IF 170 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXDIM )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) DIM2( I ) IF( IERR.GT.0.OR.DIM2( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( DIM2( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 170 END IF END IF NDIM2 = I ELSE IF( INLN( IB:IE ).EQ.'LDA' )THEN * * Read the values for leading dimension (LDA). * IF( NLDA.NE.0 )THEN ERR3 = .TRUE. END IF 180 IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXLDA )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) LDA( I ) IF( IERR.GT.0.OR.LDA( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( LDA( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 180 END IF END IF NLDA = I ELSE IF( INLN( IB:IE ).EQ.'SSYMM'.OR.INLN( IB:IE ).EQ.'SSYRK'.OR. $ INLN( IB:IE ).EQ.'SSYR2K'.OR.INLN( IB:IE ).EQ.'STRMM'.OR. $ INLN( IB:IE ).EQ.'STRSM' )THEN * * Read which routines to time. * MATCH = 0 DO 190, I = 1, MXSUB IF( NAME( I ).EQ.INLN( IB:IB+5 ) )THEN MATCH = I IF( SUBCHK( MATCH ) )THEN ERR3 = .TRUE. END IF SUBCHK( MATCH ) = .TRUE. END IF 190 CONTINUE IF( GETWRD( INLNA( JE+1 ), LLN-JE-1, KB, KE ) )THEN JB = JE + KB JE = JE + KE * * Time the routine if the first non-blank character * INLN( JB:JB ) is 'T' or 't'. * TABSUB( MATCH ) = LSAME( INLN( JB:JB ), 'T' ) IF( .NOT.( TABSUB( MATCH ).OR. $ LSAME( INLN( JB:JB ), 'F' ) ) )THEN ERR1 = .TRUE. END IF SUB = SUB.OR.TABSUB( MATCH ) I = 1 ELSE I = 0 END IF ELSE WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: Unknown parameter ', INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP END IF * IF( I.EQ.0 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: No values or erroneous values given ', $ 'for the parameter ', INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR1 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Erroneus value or too many values for the parameter ', $ INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR2 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Value too large for ', INLN( IB:IE ), '. Max ', NMAX, '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR3 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Multiple specifications of the input parameter ', $ INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR4 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = 9010 ) $ 'The label of this test is too long. Max ', LST, $ ' characters.' WRITE( NERR, FMT = * ) STOP END IF GO TO 10 * 200 CONTINUE IF( NTAB.LE.0 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: No results are chosen to be presented' WRITE( NERR, FMT = * ) $ ' (see the parameter TAB).' WRITE( NERR, FMT = * ) STOP END IF IF( ( TAB( 2 ).OR.TAB( 3 ).OR.TAB( 4 ).OR.TAB( 5 ).OR.TAB( 6 ) ) $ .AND.( NRUNS.LE.0.OR.NSIDE.LE.0.OR.NUPLO.LE.0.OR. $ NTRNS.LE.0.OR.NDIAG.LE.0.OR.NDIM1.LE.0.OR. $ NDIM2.LE.0.OR.NLDA.LE.0.OR.( .NOT.SUB ) ) )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: A parameter, or values for a parameter, is missing.' WRITE( NERR, FMT = * ) $ 'One (or more) of the input parameters RUNS, SIDE, UPLO,' WRITE( NERR, FMT = * ) $ 'TRANS, DIAG, DIM1, DIM2, LDA are missing, or none of the' WRITE( NERR, FMT = * ) $ 'routines SSYMM, SSYRK, SSYR2K, STRMM, and STRSM are marked' WRITE( NERR, FMT = * ) $ 'to be timed', '.' WRITE( NERR, FMT = * ) STOP END IF IF( NDIM1.NE.NDIM2 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: Different number of dimensions ', $ 'for DIM1 and DIM2', '.' WRITE( NERR, FMT = * ) STOP END IF * * Initialize the matrices A and B. * DO 220, J = 1, NMAX DO 210, I = 1, NMAX A( I, J ) = ONE + 0.08E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) 210 CONTINUE 220 CONTINUE DO 240, J = 1, NMAX DO 230, I = 1, NMAX B( I, J ) = ONE + 0.04E+0*REAL( I+( J-1 )*NMAX )/ $ REAL( NMAX*NMAX+1 ) 230 CONTINUE 240 CONTINUE * * Time the routines and calculate the results. * IF( TAB( 2 ).OR.TAB( 6 ) )THEN * * Time the internal GEMM-Based Level 3 BLAS routines (SGB02, * SGB04, SGB08, SGB08, and SGB09). * CALL SGBT01( 'G', TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXDIM, MXLDA, RUNS, GBRES ) END IF IF( TAB( 1 ).OR.TAB( 3 ).OR.TAB( 5 ).OR.TAB( 6 ) )THEN * * Time the user-supplied Level 3 BLAS library. * CALL SGBT01( 'U', TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXDIM, MXLDA, RUNS, USRES ) END IF IF( TAB( 1 ).OR.TAB( 4 ).OR.TAB( 5 ) )THEN * * Time SGEMM using user specified parameters. * CALL SGBT02( TABSUB, SIDE, NSIDE, NUPLO, TRNS, NTRNS, NDIAG, $ DIM1, DIM2, NDIM1, LDA, NLDA, ALPHA, BETA, $ A, B, C, LD, NMAX, NERR, MXSUB, MXOPT, $ MXDIM, MXLDA, RUNS, MMRES ) END IF IF( TAB( 1 ) )THEN * * Calculate and print the collected benchmark result. * CALL SGBTP1( TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, NTRNS, $ DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, NOUT, $ NERR, MXSUB, MXOPT, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES ) END IF IF( TAB( 2 ).OR.TAB( 3 ).OR.TAB( 4 ).OR.TAB( 5 ).OR.TAB( 6 ) )THEN * * Calculate and print the results of TAB choice 2 - 6. * CALL SGBTP2( TAB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ NOUT, MXTAB, MXSUB, MXOPT, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES, GBRES ) END IF * STOP * 9000 FORMAT( A ) 9010 FORMAT( 1X, A, I3, A ) 9020 FORMAT( I50 ) * * End of SGBTIM. * END SHAR_EOF fi # end of overwriting check if test -f 'sgbtp1.f' then echo shar: will not over-write existing file "'sgbtp1.f'" else cat << SHAR_EOF > 'sgbtp1.f' SUBROUTINE SGBTP1( TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, NTRNS, $ DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, NOUT, $ NERR, MXSUB, MXOPT, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES ) * .. Scalar Arguments .. INTEGER NOUT, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXDIM, MXLDA, RUNS REAL ALPHA, BETA * .. Parameters .. INTEGER LST PARAMETER ( LST = 50 ) * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER LBL*( LST ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXOPT ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) REAL USRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ) * * * SGBTP1 prints the collected benchmark result which is calculated from * performance results of the user-supplied Level 3 routines for * problems specified in the input file. The result consists of a tuple * ( x, y ), where x is the mean value of the GEMM-Efficiency and y is * the mean value of the performance of SGEMM in megaflops. SGEMM is * timed for problems corresponding to those specified for the remaining * Level 3 routines. * * The purpose of the collected benchmark result is to provide an * overall performance measure of the user-supplied Level 3 BLAS * routines. The intention is to expose the capacity of the target * machine for these kinds of problems and to show how well the routines * utilize the machine. Furthermore, the collected result is intended to * be easy to compare between different target machines. See the README * and INSTALL files for further information. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, D, L, NTIM, OP1, OP2, OP3 REAL SPEED, EFF, MM, MMSUM, EFSUM * .. Intrinsic Functions .. INTRINSIC REAL * .. Parameters .. REAL ZERO INTEGER MXBSUB PARAMETER ( ZERO = 0.0E+0, MXBSUB = 5 ) * .. * .. Executable Statements .. IF( MXSUB.GT.MXBSUB )THEN WRITE( NERR, FMT = 9000 ) STOP END IF * MMSUM = ZERO EFSUM = ZERO NTIM = 0 * * ------ Stop indentation ------ * DO 50, L = 1, NLDA DO 40, OP1 = 1, NSIDE DO 30, OP2 = 1, NUPLO DO 20, OP3 = 1, NTRNS DO 10, D = 1, NDIM * * ------ Continue indentation ------ * * * Compute the sum of the performance of SGEMM in megaflops (MMSUM) * and the sum of the GEMM-Efficiency (EFSUM). * IF( TABSUB( 1 ).AND.OP3.EQ.1 )THEN MM = MMRES( 1, OP1, OP2, 1, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 1, OP1, OP2, 1, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 2 ).AND.OP1.EQ.1 )THEN MM = MMRES( 2, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 2, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 3 ).AND.OP1.EQ.1 )THEN MM = MMRES( 3, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 3, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 4 ) )THEN MM = MMRES( 4, OP1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 4, OP1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 5 ) )THEN MM = MMRES( 5, OP1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 5, OP1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF * * ------ Stop indentation ------ * 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE * * ------ Continue indentation ------ * * * Compute the collected benchmark result ( x, y ) as the mean value * of the GEMM-Efficiency ( x ) and the mean value of the performance * of SGEMM in megaflops ( y ). * SPEED = MMSUM/REAL( NTIM ) EFF = EFSUM/REAL( NTIM ) * * Print an introduction and the collected benchmark result. * WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9020 ) WRITE( NOUT, FMT = 9030 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9040 ) RUNS WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9050 ) WRITE( NOUT, FMT = 9060 ) 'SIDE ', ( SIDE( I ), I = 1, NSIDE ) WRITE( NOUT, FMT = 9060 ) 'UPLO ', ( UPLO( I ), I = 1, NUPLO ) WRITE( NOUT, FMT = 9060 ) 'TRANS ', ( TRNS( I ), I = 1, NTRNS ) WRITE( NOUT, FMT = 9060 ) 'DIAG ', ( DIAG( I ), I = 1, NDIAG ) WRITE( NOUT, FMT = 9070 ) 'DIM1 ', ( DIM1( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9070 ) 'DIM2 ', ( DIM2( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9070 ) 'LDA ', ( LDA( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9080 ) 'ALPHA ', ALPHA WRITE( NOUT, FMT = 9080 ) 'BETA ', BETA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9090 ) LBL WRITE( NOUT, FMT = 9100 ) EFF, SPEED WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) * RETURN * * Print formats. * 9000 FORMAT( 1X, 'Error: The collected benchmark result could not ', $ 'be obtained.',/, $ 1X, 'The value for the input parameter MXSUB is too ', $ 'large.' ) 9010 FORMAT( 1X, 'Error: The collected benchmark result could not ', $ 'be obtained.',/, $ 1X, 'Execution time for SGEMM is zero.' ) 9020 FORMAT( 17X, '**** GEMM-Based Level 3 BLAS Benchmark ****' ) 9030 FORMAT( 27X, 'Collected Benchmark Result',/, $ 32X, ' Real ' ) 9040 FORMAT( 2X, 'The collected benchmark result is a tuple ', $ '( x, y ) where x is the mean',/, $ 2X, 'value of the GEMM-Efficiency and y is the mean ', $ 'value of the performance',/, $ 2X, 'of SGEMM in megaflops (see the README file). The ', $ 'benchmark result is',/, $ 2X, 'based on the shortest of', I3,' runs for each ', $ 'problem configuration.' ) 9050 FORMAT( 8X, 'Input parameters.' ) 9060 FORMAT( 8X, A, ' ', 10( A, ' ' ) ) 9070 FORMAT( 8X, A, 1X, 12( I5 ), 2( /, 16X, 12( I5 ) ) ) 9080 FORMAT( 8X, A, F6.1 ) 9090 FORMAT( 8X, 'Test label: ', A ) 9100 FORMAT( 8X, 'Collected result: (', F7.2,',', F9.1,' )' ) 9110 FORMAT( 1X, '**************************************************', $ '****************************' ) * * End of SGBTP1. * END SHAR_EOF fi # end of overwriting check if test -f 'sgbtp2.f' then echo shar: will not over-write existing file "'sgbtp2.f'" else cat << SHAR_EOF > 'sgbtp2.f' SUBROUTINE SGBTP2( TAB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, $ NOUT, MXTAB, MXSUB, MXOPT, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES, GBRES ) * .. Scalar Arguments .. INTEGER NOUT, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXTAB, MXSUB, MXOPT, MXDIM, MXLDA, RUNS REAL ALPHA, BETA * .. Parameters .. INTEGER LST PARAMETER ( LST = 50 ) * .. Array Arguments .. LOGICAL TABSUB( MXSUB ), TAB( MXTAB ) CHARACTER LBL*( LST ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXOPT ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) REAL USRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ GBRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXOPT, MXOPT, $ MXDIM, MXLDA ) * * * SGBTP2 prints tables showing detailed performance results and * comparisons between the user-supplied and the built-in GEMM-Based * Level 3 BLAS routines. The table results are intended for program * developers and others who are interested in detailed performance * presentations. Performance of the user-supplied and the built-in * GEMM-Based Level 3 BLAS routines are shown. The tables also show * GEMM-Efficiency and GEMM-Ratio. See the README and INSTALL files * for further information. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER D, I, L, NTIM, OP1, OP2, OP3, OP4 REAL MM, GE, GB, GR, US * .. Parameters .. INTEGER MXTOTS, LLN REAL ZERO, HUGE PARAMETER ( MXTOTS = 6, LLN = 256, ZERO = 0.0E+0, $ HUGE = 1.0E+10 ) INTEGER B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, B11, $ E1, E2, E3, E4, E5, E6, E7, E8, E9, E10, E11 PARAMETER ( B1 = 1, B2 = 3, B3 = 5, B4 = 7, B5 = 9, $ B6 = 16, B7 = 23, B8 = 34, B9 = 45, B10 = 56, $ B11 = 66, $ E1 = 2, E2 = 4, E3 = 6, E4 = 8, E5 = 15, $ E6 = 22, E7 = 33, E8 = 44, E9 = 55, E10 = 65, $ E11 = 74 ) * .. Local Arrays .. CHARACTER OUTLN*( LLN ), OUTLN2*( LLN ), OUTLN3*( LLN ) REAL MI( MXTOTS ), MA( MXTOTS ), SU( MXTOTS ) * .. * .. Executable Statements .. * * Print an introduction. * WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9000 ) WRITE( NOUT, FMT = 9010 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9020 ) WRITE( NOUT, FMT = 9030 ) 'SIDE ', ( SIDE( I ), I = 1, NSIDE ) WRITE( NOUT, FMT = 9030 ) 'UPLO ', ( UPLO( I ), I = 1, NUPLO ) WRITE( NOUT, FMT = 9030 ) 'TRANS ', ( TRNS( I ), I = 1, NTRNS ) WRITE( NOUT, FMT = 9030 ) 'DIAG ', ( DIAG( I ), I = 1, NDIAG ) WRITE( NOUT, FMT = 9040 ) 'DIM1 ', ( DIM1( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9040 ) 'DIM2 ', ( DIM2( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9040 ) 'LDA ', ( LDA( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9050 ) 'ALPHA ', ALPHA WRITE( NOUT, FMT = 9050 ) 'BETA ', BETA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9060 ) RUNS WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9070 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9080 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9090 ) LBL WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) * * Print result tables for SSYMM. * IF( TABSUB( 1 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'SSYMM ', $ ' OPTIONS = SIDE,UPLO' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 50, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 10, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 10 CONTINUE NTIM = 0 DO 40, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 30, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 20, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 1, OP1, OP2, 1, 1, D, L ) MM = MMRES( 1, OP1, OP2, 1, 1, D, L ) GB = GBRES( 1, OP1, OP2, 1, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B7:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 20 CONTINUE 30 CONTINUE 40 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 50 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for SSYRK. * IF( TABSUB( 2 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'SSYRK ', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 100, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 60, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 60 CONTINUE NTIM = 0 DO 90, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 80, OP3 = 1, NTRNS WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 70, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 2, 1, OP2, OP3, 1, D, L ) MM = MMRES( 2, 1, OP2, OP3, 1, D, L ) GB = GBRES( 2, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 70 CONTINUE 80 CONTINUE 90 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 100 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for SSYR2K. * IF( TABSUB( 3 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'SSYR2K', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 150, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 110, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 110 CONTINUE NTIM = 0 DO 140, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 130, OP3 = 1, NTRNS WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 120, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 3, 1, OP2, OP3, 1, D, L ) MM = MMRES( 3, 1, OP2, OP3, 1, D, L ) GB = GBRES( 3, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 120 CONTINUE 130 CONTINUE 140 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 150 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for STRMM. * IF( TABSUB( 4 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'STRMM ', $ 'OPTIONS = SIDE,UPLO,TRANS,DIAG' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 220, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 160, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 160 CONTINUE NTIM = 0 DO 210, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 200, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) DO 190, OP3 = 1, NTRNS WRITE( OUTLN( B3:E3 ), FMT = 9130 ) TRNS( OP3 ) DO 180, OP4 = 1, NDIAG WRITE( OUTLN( B4:E4 ), FMT = 9130 ) DIAG( OP4 ) DO 170, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 4, OP1, OP2, OP3, OP4, D, L ) MM = MMRES( 4, OP1, OP2, OP3, OP4, D, L ) GB = GBRES( 4, OP1, OP2, OP3, OP4, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 170 CONTINUE 180 CONTINUE 190 CONTINUE 200 CONTINUE 210 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 220 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for STRSM. * IF( TABSUB( 5 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'STRSM ', $ 'OPTIONS = SIDE,UPLO,TRANS,DIAG' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 290, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 230, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 230 CONTINUE NTIM = 0 DO 280, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 270, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) DO 260, OP3 = 1, NTRNS WRITE( OUTLN( B3:E3 ), FMT = 9130 ) TRNS( OP3 ) DO 250, OP4 = 1, NDIAG WRITE( OUTLN( B4:E4 ), FMT = 9130 ) DIAG( OP4 ) DO 240, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 5, OP1, OP2, OP3, OP4, D, L ) MM = MMRES( 5, OP1, OP2, OP3, OP4, D, L ) GB = GBRES( 5, OP1, OP2, OP3, OP4, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9190 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 240 CONTINUE 250 CONTINUE 260 CONTINUE 270 CONTINUE 280 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 290 CONTINUE END IF WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9260 ) * RETURN * * Print formats. * 9000 FORMAT( 17X, '**** GEMM-Based Level 3 BLAS Benchmark ****' ) 9010 FORMAT( 33X, 'Table Results',/, $ 32X, ' Real ' ) 9020 FORMAT( 8X, 'Input parameters.' ) 9030 FORMAT( 8X, A, 3X, 10( A, ' ' ) ) 9040 FORMAT( 8X, A, 1X, 12( I5 ), 2( /, 16X, 12( I5 ) ) ) 9050 FORMAT( 8X, A, F6.1 ) 9060 FORMAT( 8X, 'Results are based on the shortest execution time ', $ 'of ', I2, ' runs for ',/, $ 8X, 'each problem configuration.' ) 9070 FORMAT( 27X, 'Performance of a user-supplied',/, $ 27X, 'Level 3 BLAS routine (megaflops).',/, $ 8X, 'GEMM-Efficiency = -------------------------------', $ '----',/, $ 27X, 'Performance of the user-supplied',/, $ 27X, 'SGEMM routine (megaflops).' ) 9080 FORMAT( 22X, 'Performance for the internal GEMM-Based',/, $ 22X, 'Level 3 BLAS routine Sxxxx (megaflops).',/, $ 8X, 'GEMM-Ratio = ------------------------------------', $ '-----',/, $ 22X, 'Performance of the user-supplied',/, $ 22X, 'Level 3 BLAS routine Sxxxx (megaflops).' ) 9090 FORMAT( 8X, 'Test label: ', A ) 9100 FORMAT( 2X, A, 38X, A ) 9110 FORMAT( 31X, 'GEMM- User-', /, $ 29X,'Based lib suppl lib SGEMM GEMM- GEMM-', /, $ 2X, 'OPTIONS ', A,' ', A,' ', $ 'Mflops Mflops Mflops Eff. Ratio', /, $ 2X, '==================================================', $ '=========================' ) 9120 FORMAT( 2X, '( LDA = ', I4, ' )' ) 9130 FORMAT( A ) 9140 FORMAT( I7 ) 9150 FORMAT( F11.1 ) 9160 FORMAT( ' ' ) 9170 FORMAT( F10.2 ) 9180 FORMAT( ' ' ) 9190 FORMAT( F9.2 ) 9200 FORMAT( ' ' ) 9210 FORMAT( 2X, A ) 9220 FORMAT( 2X, '--------------------------------------------------', $ '-------------------------' ) 9230 FORMAT( 'Min ', 15X ) 9240 FORMAT( 'Max ', 15X ) 9250 FORMAT( 'Mean ', 15X ) 9260 FORMAT( 1X, '**************************************************', $ '****************************' ) * * End of SGBTP2. * END SHAR_EOF fi # end of overwriting check if test -f 'smark01.in' then echo shar: will not over-write existing file "'smark01.in'" else cat << SHAR_EOF > 'smark01.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * SMARK01 * * * We propose two standard test suits for the collected benchmark * result, SMARK01 and SMARK02 (see the files 'smark01.in' and * 'smark02.in'). These tests are designed to show performance of the * user-supplied Level 3 library for problem sizes that are likely to * often be requested by a calling routine. This imply problems that * presumably constitute a large part of computations in routines which * use the Level 3 BLAS as their major computational kernels. LAPACK * implements blocked algorithms which are based on calls to the Level 3 * BLAS. The problems in the two tests are similar. However, some of the * matrix dimensions are larger in SMARK02 than in SMARK01. This * corresponds to larger matrix blocks in the calling routine. The tests * are expected to match various target machines differently. * Performance results may depend strongly on sizes of different storage * units in the memory hierarchy. The size of the cache memory, for * instance, may be decisive. For this reason, we propose two standard * tests instead of one. * * *** Label of this test *** LBL SMARK01 *** Benchmark results to be presented *** TAB 1 3 4 5 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 3 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T DIAG N U DIM1 16 32 512 512 512 DIM2 512 512 16 32 512 LDA 512 530 *** Routines to be timed *** SSYMM T SSYRK T SSYR2K T STRMM T STRSM T SHAR_EOF fi # end of overwriting check if test -f 'smark02.in' then echo shar: will not over-write existing file "'smark02.in'" else cat << SHAR_EOF > 'smark02.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * SMARK02 * * * We propose two standard test suits for the collected benchmark * result, SMARK01 and SMARK02 (see the files 'smark01.in' and * 'smark02.in'). These tests are designed to show performance of the * user-supplied Level 3 library for problem sizes that are likely to * often be requested by a calling routine. This imply problems that * presumably constitute a large part of computations in routines which * use the Level 3 BLAS as their major computational kernels. LAPACK * implements blocked algorithms which are based on calls to the Level 3 * BLAS. The problems in the two tests are similar. However, some of the * matrix dimensions are larger in SMARK02 than in SMARK01. This * corresponds to larger matrix blocks in the calling routine. The tests * are expected to match various target machines differently. * Performance results may depend strongly on sizes of different storage * units in the memory hierarchy. The size of the cache memory, for * instance, may be decisive. For this reason, we propose two standard * tests instead of one. * * *** Label of this test *** LBL SMARK02 *** Benchmark results to be presented *** TAB 1 3 4 5 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 3 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T DIAG N U DIM1 64 128 512 512 512 DIM2 512 512 64 128 512 LDA 512 530 *** Routines to be timed *** SSYMM T SSYRK T SSYR2K T STRMM T STRSM T SHAR_EOF fi # end of overwriting check if test -f 'ssbpm.f' then echo shar: will not over-write existing file "'ssbpm.f'" else cat << SHAR_EOF > 'ssbpm.f' PROGRAM SSBPM * * SSBPM re-writes GEMM-Based Level 3 BLAS source files replacing lines * containing old PARAMETER statements for user specified parameters, * with lines containing new PARAMETER statements given in an input * file. The user can conveniently assign new values to the PARAMETER * statements in the input file, and then run SSBPM to distribute these * values to the GEMM-based routines. An input file consists of three * different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file (see the input file * 'sgpm.in'). Read the file INSTALL for further instructions. * * * -- Written in January-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, IB, IE, JB, JE, KB, KE, LB, LE, NAM, NXTLN LOGICAL PMEOF * .. External Functions .. LOGICAL LNCMP, GETWRD INTEGER EOLN EXTERNAL LNCMP, GETWRD, EOLN * .. Parameters .. INTEGER NPM, NGB, NTMP, NERR PARAMETER ( NPM = 5, NERR = 6, NGB = 10, NTMP = 12 ) INTEGER NLNS, LLN PARAMETER ( NLNS = 10, LLN = 256 ) CHARACTER TMPNAM*( LLN ) PARAMETER ( TMPNAM = 'tmpgb.tmp' ) * .. Local Arrays .. CHARACTER PMLN*( LLN ), GBLN*( LLN ), GBNAM*( LLN ), $ STRS( NLNS, 2 )*( LLN ), BNAM( NLNS )*( LLN ) CHARACTER PMLNA( LLN ), GBLNA( LLN ), GBNAMA( LLN ), $ STRSA( LLN, NLNS, 2 ), BNAMA( LLN, NLNS ) EQUIVALENCE ( PMLN, PMLNA ), ( GBLN, GBLNA ), $ ( GBNAM, GBNAMA ), ( STRS, STRSA ), $ ( BNAM, BNAMA ) * .. Data statements .. DATA BNAM/ $'sgb02.f' ,'sgb04.f' ,'sgb06.f' ,'sgb08.f' ,'sgb09.f' , $'sgb90.f' ,' ',' ','sgb91.f' ,' '/ DATA STRS/ $'ssymm.f' ,'ssyrk.f' ,'ssyr2k.f' ,'strmm.f' ,'strsm.f' , $'sbigp.f' ,' ',' ','scld.f' ,' ', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( SIP41 = $$ , SIP42 = $$ ,', $'$ SIP81 = $$ , SIP82 = $$ , SIP83 = $$ ,', $'$ SIP91 = $$ , SIP92 = $$ , SIP93 = $$ )', $'PARAMETER ( LNSZ = $$ , NPRT = $$ , PRTSZ = $$ ,', $'$ LOLIM = $$ , SP = $$ )' / * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. * 10 READ( NPM, FMT = 9000, END = 110 ) GBNAM IF( .NOT.GETWRD( GBNAMA, LLN, IB, IE ).OR. $ ( GBNAM( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * Check if the first word on the line is the name of a file that is * due to be changed. * 20 NAM = -1 PMEOF = .FALSE. DO 30, I = 1, NLNS IF( GBNAM( IB:IE ).EQ.STRS( I, 1 ) )THEN NAM = I IF( .NOT.GETWRD( BNAMA( 1, NAM ), LLN, LB, LE ) )THEN WRITE( NERR, FMT = * ) $ 'Benchmark routine name corresponding to ', $ GBNAM( IB:IE ), ' is missing in SSBPM.' STOP END IF END IF 30 CONTINUE IF( NAM.EQ.-1 )THEN WRITE( NERR, FMT = * )'Unknown routine name: ', GBNAM( IB:IE ) STOP END IF * * Read the next non-blank/non-comment line from the input parameter * file. * 40 READ( NPM, FMT = 9000, END = 110 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 40 END IF * * Copy each line of the GEMM-Based file, except for the lines that * are due to be changed, to the temporary file TMPNAM. Copy the * lines that should be changed from the input parameter file. Check * that the lines in the parameter file are correct compared to STRS. * NXTLN = NAM IF( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN OPEN( NGB, FILE = BNAM( NAM )( LB:LE ), STATUS = 'OLD' ) OPEN( NTMP, FILE = TMPNAM, STATUS = 'NEW' ) 50 READ( NGB, FMT = 9000, END = 80 ) GBLN IF( LNCMP( GBLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN WRITE( NTMP, FMT = 9010 ) PMLN( 1:EOLN( PMLNA, LLN ) ) 60 READ( NPM, FMT = 9000, END = 70 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 60 END IF IF( .NOT.GETWRD( STRSA( 1, NXTLN+1, 1 ), LLN, KB, KE ).AND. $ ( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN+1, 2 ), LLN ) ) $ )THEN NXTLN = NXTLN + 1 END IF ELSE WRITE( NTMP, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) END IF GO TO 50 70 PMEOF = .TRUE. GO TO 50 80 CLOSE( NGB, STATUS = 'DELETE' ) CLOSE( NTMP, STATUS = 'KEEP' ) ELSE WRITE( NERR, FMT = * )'Error in parameter file: ' WRITE( NERR, FMT = * ) PMLN STOP END IF * * Write back the temporary file TMPNAM to the GEMM-Based file and * remove the temporary file. * OPEN( NTMP, FILE = TMPNAM, STATUS = 'OLD' ) OPEN( NGB, FILE = BNAM( NAM )( LB:LE ), STATUS = 'NEW' ) 90 READ( NTMP, FMT = 9000, END = 100 ) GBLN WRITE( NGB, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) GO TO 90 100 CONTINUE CLOSE( NTMP, STATUS = 'DELETE' ) CLOSE( NGB, STATUS = 'KEEP' ) GBNAM = PMLN IB = JB IE = JE * IF( .NOT.PMEOF )THEN GO TO 20 END IF 110 CONTINUE * STOP * 9000 FORMAT( A ) 9010 FORMAT( A ) * * End of SSBPM. * END LOGICAL FUNCTION LNCMP( LN1, LEN1, LN2, LEN2 ) * .. Scalar Arguments .. INTEGER LEN1, LEN2 * .. Array Arguments .. CHARACTER LN1( LEN1 ), LN2( LEN2 ) * * Compare the character strings LN1 and LN2. Return .TRUE. if the * strings are identical except from wild cards ($$) corresponding * to positive integers and except from a different number of * consecutive blanks between tokens. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER I, J LOGICAL MATCH * .. Intrinsic Functions .. INTRINSIC LGE, LLE LOGICAL LGE, LLE * .. * .. Executable Statements .. * * Find the beginning of the next tokens in LN1 and LN2. * I = 1 J = 1 10 IF( ( LN1( I ).EQ.' ' ).AND.( I.LT.LEN1 ) )THEN I = I + 1 GO TO 10 END IF 20 IF( ( LN2( J ).EQ.' ' ).AND.( J.LT.LEN2 ) )THEN J = J + 1 GO TO 20 END IF * * Compare the tokens. * IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.LT.LEN1 ).AND. $ ( J.LT.LEN2 ) )THEN I = I + 1 J = J + 1 GO TO 10 ELSE IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.EQ.LEN1 ).AND. $ ( J.EQ.LEN2 ) )THEN LNCMP = .TRUE. RETURN ELSE IF( ( I.EQ.LEN1 ).AND.( J.EQ.LEN2 ) )THEN LNCMP = .FALSE. RETURN ELSE IF( LN1( I ).EQ.'$' )THEN IF( I.LT.LEN1-1 )THEN IF( LN1( I+1 ).EQ.'$' )THEN I = I + 2 MATCH = .FALSE. 30 IF( ( LGE( LN2( J ), '0' ).AND.LLE( LN2( J ), '9' ) ) $ .AND.( J.LT.LEN2 ) )THEN J = J + 1 MATCH = .TRUE. GO TO 30 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 ELSE IF( LN2( J ).EQ.'$' )THEN IF( J.LT.LEN2-1 )THEN IF( LN2( J+1 ).EQ.'$' )THEN J = J + 2 MATCH = .FALSE. 40 IF( ( LGE( LN1( I ), '0' ).AND.LLE( LN1( I ), '9' ) ) $ .AND.( I.LT.LEN1 ) )THEN I = I + 1 MATCH = .TRUE. GO TO 40 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 END IF * LNCMP = .FALSE. RETURN * * End of LNCMP. * END SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'TMGLIB' then mkdir 'TMGLIB' fi cd 'TMGLIB' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### Timing library ##################################################### all: $(CTMG) TIMELIB = $(CTMG) CSECS = second.f dsecnd.f CSEC = second.o dsecnd.o $(CTMG): $(CSEC) $(ARCH) $(ARCHFLAGS) $(TIMELIB) $(CSEC) $(RANLIB) $(TIMELIB) $(CSEC): $(CSECS) $(FORTRAN) -c $(TMGOPT) $(CSECS) clean: rm -f *.o SHAR_EOF fi # end of overwriting check if test -f 'dsecnd.f' then echo shar: will not over-write existing file "'dsecnd.f'" else cat << SHAR_EOF > 'dsecnd.f' DOUBLE PRECISION FUNCTION DSECND( ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * Purpose * ======= * * DSECND returns the user time for a process in seconds. * This version gets the time from the system function ETIME. * * ===================================================================== * * .. Local Scalars .. REAL T1 * .. * .. Local Arrays .. REAL TARRAY( 2 ) * .. * .. External Functions .. REAL ETIME EXTERNAL ETIME * .. * .. Executable Statements .. * T1 = ETIME( TARRAY ) DSECND = TARRAY( 1 ) RETURN * * End of DSECND * END SHAR_EOF fi # end of overwriting check if test -f 'second.f' then echo shar: will not over-write existing file "'second.f'" else cat << SHAR_EOF > 'second.f' REAL FUNCTION SECOND( ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * Purpose * ======= * * SECOND returns the user time for a process in seconds. * This version gets the time from the system function ETIME. * * ===================================================================== * * .. Local Scalars .. REAL T1 * .. * .. Local Arrays .. REAL TARRAY( 2 ) * .. * .. External Functions .. REAL ETIME EXTERNAL ETIME * .. * .. Executable Statements .. * T1 = ETIME( TARRAY ) SECOND = TARRAY( 1 ) RETURN * * End of SECOND * END SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'ZBENCH' then mkdir 'ZBENCH' fi cd 'ZBENCH' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### GEMM-Based Level 3 BLAS Benchmark #################################### # # The following libraries are specified, a user specified level 3 BLAS # library to be timed (LIB3B), a library with underlying BLAS routines # (LIB12B) where the underlying BLAS routine ZGEMM may be specified # separately, and the library with the timing functions SECOND and # DSECND (ZSEC). # LIB3B = $(ULIB) ZGEMM = $(UULIB) LIB12B = $(UULIB) ZSEC = $(UTMG) # # LIB specifies the order in which the libraries are linked with the # benchmark programs. Notice that the built-in GEMM-based routines # will be linked the first ZGEMM, level 1 and 2 BLAS routines found # as underlying routines. Change the order in which the libraries are # linked as desired. # LIB = $(ZSEC) $(LIB3B) $(ZGEMM) $(LIB12B) # ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # ZBMFLG : the GEMM-based performance benchmark programs # ZPRFLG : routines that print the output results # ZGBFLG : the built-in GEMM-based level 3 BLAS routines # ZAXFLG : GEMM-based specific auxiliary routines # AXOPT : other auxiliary routines # ZBMFLG = $(GBBOPT) ZPRFLG = $(AXOPT) ZGBFLG = $(GBOPT) ZAXFLG = $(GBOPT) AXFLG = $(AXOPT) # ######################################################################## ZTIMS = zgbtim.f ZTIM = zgbtim.o ZBMS = zgbt01.f zgbt02.f ZBM = zgbt01.o zgbt02.o ZPRS = zgbtp1.f zgbtp2.f ZPR = zgbtp1.o zgbtp2.o ZGBS = zgb02.f zgb03.f zgb04.f zgb05.f zgb06.f zgb07.f zgb08.f zgb09.f ZGB = zgb02.o zgb03.o zgb04.o zgb05.o zgb06.o zgb07.o zgb08.o zgb09.o ZAUXS = zgb90.f zgb91.f ZAUX = zgb90.o zgb91.o AUXS = lsame.f xerbla.f AUX = lsame.o xerbla.o ZPRMS = zsbpm.f ZPRM = zsbpm.o AUXS2 = getwrd.f eoln.f AUX2 = getwrd.o eoln.o OBJ1 = $(ZTIM) $(ZBM) $(ZGB) $(ZAUX) $(AUX) $(AUX2) $(ZPR) OBJ2 = $(ZPRM) $(AUX2) ######################################################################## all: zgbtim zsbpm zgbtim: $(OBJ1) $(LOADER) $(LOADOPT) -o zgbtim $(OBJ1) $(LIB) zsbpm: $(OBJ2) $(LOADER) $(LOADOPT) -o zsbpm $(OBJ2) $(ZTIM): $(ZTIMS) $(FORTRAN) -c $(ZBMFLG) $(ZTIMS) $(ZBM): $(ZBMS) $(FORTRAN) -c $(ZBMFLG) $(ZBMS) $(ZPR): $(ZPRS) $(FORTRAN) -c $(ZPRFLG) $(ZPRS) $(ZGB): $(ZGBS) $(FORTRAN) -c $(ZGBFLG) $(ZGBS) $(ZAUX): $(ZAUXS) $(FORTRAN) -c $(ZAXFLG) $(ZAUXS) $(AUX): $(AUXS) $(FORTRAN) -c $(AXFLG) $(AUXS) $(ZPRM): $(ZPRMS) $(FORTRAN) -c $(AXFLG) $(ZPRMS) $(AUX2): $(AUXS2) $(FORTRAN) -c $(AXFLG) $(AUXS2) clean: rm -f *.o zgbtim zsbpm SHAR_EOF fi # end of overwriting check if test -f 'eoln.f' then echo shar: will not over-write existing file "'eoln.f'" else cat << SHAR_EOF > 'eoln.f' INTEGER FUNCTION EOLN( LN, LLN ) * .. Scalar Arguments .. INTEGER LLN * .. Array Arguments .. CHARACTER LN( LLN ) * * Return the index of the last non-blank character in the last word * (token) of LN. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER IE * .. * .. Executable Statements .. * * Find the end of the last word (token) of LN. * IE = LLN 10 IF( ( LN( IE ).EQ.' ' ).AND.( IE.GE.1 ) )THEN IE = IE - 1 GO TO 10 END IF EOLN = IE * RETURN * * End of EOLN. * END SHAR_EOF fi # end of overwriting check if test -f 'example.in' then echo shar: will not over-write existing file "'example.in'" else cat << SHAR_EOF > 'example.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * Example input file * Double Complex * * * Benchmark results to be presented (parameter TAB): * * 1 The collected benchmark result. * * 2 Performance of the built-in GEMM-Based Level 3 BLAS library * in megaflops. * * 3 Performance of the user-supplied Level 3 BLAS library in * megaflops. * * 4 Performance of the user-supplied ZGEMM routine in megaflops. * Problem configurations for ZGEMM are chosen to 'correspond' to * those in 2 and 3 for timing purposes, see section 3. * * 5 GEMM-Efficiency of the user-supplied Level 3 routines. * * Performance of a user-supplied * Level 3 BLAS routine (megaflops). * GEMM-Efficiency = ----------------------------------- * Performance of the user-supplied * ZGEMM routine (megaflops). * * 6 GEMM-Ratio. * * Performance of the internal GEMM-Based * Level 3 BLAS routine Zxxxx (megaflops). * GEMM-Ratio = ----------------------------------------- * Performance of the user-supplied * Level 3 BLAS routine Zxxxx (megaflops). * *** Label of this test *** LBL Example 1, double complex. *** Benchmark results to be presented *** TAB 1 2 3 4 5 6 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 2 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T C DIAG N DIM1 32 64 256 256 DIM2 256 256 32 64 LDA 256 *** Routines to be timed *** ZSYMM T ZHEMM T ZSYRK T ZHERK T ZSYR2K T ZHER2K T ZTRMM T ZTRSM T SHAR_EOF fi # end of overwriting check if test -f 'getwrd.f' then echo shar: will not over-write existing file "'getwrd.f'" else cat << SHAR_EOF > 'getwrd.f' LOGICAL FUNCTION GETWRD( LN, LLN, IB, IE ) * .. Scalar Arguments .. INTEGER LLN, IB, IE * .. Array Arguments .. CHARACTER LN( LLN ) * * Read the first non-blank word from the character string LN. Set * the indices IB and IE to the beginning and end of the word, * respectively. Return .TRUE. if a word was found and .FALSE. if no * word was found. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * .. * .. Executable Statements .. * * Find the beginning of the word. * IB = 1 10 IF( ( LN( IB ).EQ.' ' ).AND.( IB.LT.LLN ) )THEN IB = IB + 1 GO TO 10 END IF * * Find the end of the word. * IE = IB 20 IF( IE.LT.LLN )THEN IF( LN( IE+1 ).NE.' ' )THEN IE = IE + 1 GO TO 20 END IF END IF * * Check if any word was found. * IF( LN( IB ).NE.' ' )THEN GETWRD = .TRUE. ELSE GETWRD = .FALSE. END IF * RETURN * * End of GETWRD. * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'newzgpm.in' then echo shar: will not over-write existing file "'newzgpm.in'" else cat << SHAR_EOF > 'newzgpm.in' * * Example of an input file for the program ZSGPM containing user * specified parameters. * * The enclosed program ZSGPM re-writes GEMM-Based Level 3 BLAS source * files replacing lines containing old PARAMETER statements for user * specified parameters, with lines containing new PARAMETER statements * given in an input file. The user can conveniently assign new values * to the PARAMETER statements in the input file, and then run ZSGPM to * distribute these values to the GEMM-based routines. An input file * consists of three different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file. Read the file * INSTALL for further instructions on how to use this file. * zsymm.f PARAMETER ( RCB = 80, CB = 44 ) zhemm.f PARAMETER ( RCB = 80, CB = 44 ) zsyr2k.f PARAMETER ( RCB = 80, CB = 44 ) zher2k.f PARAMETER ( RCB = 80, CB = 44 ) zsyrk.f PARAMETER ( RCB = 44, RB = 44, CB = 44 ) zherk.f PARAMETER ( RCB = 44, RB = 44, CB = 44 ) ztrmm.f PARAMETER ( RCB = 44, RB = 44, CB = 44 ) ztrsm.f PARAMETER ( RCB = 44, RB = 44, CB = 44 ) zbigp.f PARAMETER ( ZIP41 = 4, ZIP42 = 3, $ ZIP51 = 4, ZIP52 = 3, $ ZIP81 = 4, ZIP82 = 3, ZIP83 = 4, $ ZIP91 = 4, ZIP92 = 3, ZIP93 = 4 ) zcld.f PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 32, ZP = 16 ) SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check if test -f 'zgb02.f' then echo shar: will not over-write existing file "'zgb02.f'" else cat << SHAR_EOF > 'zgb02.f' SUBROUTINE ZGB02 ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGB02 (ZSYMM) performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is a symmetric matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the symmetric matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the symmetric matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * symmetric matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * symmetric matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - COMPLEX*16. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZCOPY * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. User specified parameters for ZGB02 .. INTEGER RCB, CB PARAMETER ( RCB = 80, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGB02 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL ZGEMM ( 'N', 'N', M, N, 0, ZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by ZCOPY is CB. * DO 30, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 20, J = JJ+1, II+ISEC-1 CALL ZCOPY ( MIN( JSEC, J-JJ ), A( JJ, J ), 1, $ T1( J-II+1, JJ-II+1 ), RCB ) 20 CONTINUE 30 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL ZGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 80, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 50, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 50 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by ZCOPY is CB. * DO 70, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 60, J = II, JJ+JSEC-2 CALL ZCOPY ( MIN( JSEC, JJ+JSEC-1-J ), $ A( MAX( JJ, J+1 ), J ), 1, $ T1( J-II+1, MAX( JJ-II+1, J-II+2 ) ), RCB ) 60 CONTINUE 70 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF 80 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 120, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 90, J = JJ, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 90 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by ZCOPY is CB. * DO 110, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 100, I = II+1, JJ+JSEC-1 CALL ZCOPY ( MIN( ISEC, I-II ), A( II, I ), 1, $ T1( I-JJ+1, II-JJ+1 ), RCB ) 100 CONTINUE 110 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF 120 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 160, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL ZCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 130 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by ZCOPY is CB. * DO 150, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 140, I = JJ, II+ISEC-2 CALL ZCOPY ( MIN( ISEC, II+ISEC-1-I ), $ A( MAX( II, I+1 ), I ), 1, $ T1( I-JJ+1, MAX( II-JJ+1, I-JJ+2 ) ), RCB ) 140 CONTINUE 150 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 160 CONTINUE END IF END IF * RETURN * * End of ZGB02. * END SHAR_EOF fi # end of overwriting check if test -f 'zgb03.f' then echo shar: will not over-write existing file "'zgb03.f'" else cat << SHAR_EOF > 'zgb03.f' SUBROUTINE ZGB03 ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGB03 (ZHEMM) performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is an hermitian matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the hermitian matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the hermitian matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * hermitian matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * hermitian matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the hermitian matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the hermitian matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the hermitian * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the hermitian matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the hermitian matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the hermitian * matrix and the strictly upper triangular part of A is not * referenced. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN, DBLE, DCMPLX, DCONJG * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZCOPY * .. Parameters .. DOUBLE PRECISION ZERO COMPLEX*16 ZZERO, ZONE PARAMETER ( ZERO = 0.0D+0, $ ZZERO = ( 0.0D+0, 0.0D+0 ), $ ZONE = ( 1.0D+0, 0.0D+0 ) ) * .. User specified parameters for ZGB03 .. INTEGER RCB, CB PARAMETER ( RCB = 80, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGB03 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZZERO ).AND.( BETA.EQ.ZONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZZERO )THEN CALL ZGEMM ( 'N', 'N', M, N, 0, ZZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 60, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 20, I = 1, ISEC T1( I, I ) = DCMPLX( DBLE( T1( I, I ) ), ZERO ) 20 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly upper triangular diagonal block of A is copied * to the strictly lower triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 50, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 40, J = JJ+1, II+ISEC-1 DO 30, I = JJ, J-1 T1( J-II+1, I-II+1 ) = DCONJG( A( I, J ) ) 30 CONTINUE 40 CONTINUE 50 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*conjg( A' )*B + C and C := alpha*A*B + C, * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL ZGEMM ( 'C', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ZONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ZONE, C( II, 1 ), LDC ) END IF 60 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 120, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 70, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 70 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 80, I = 1, ISEC T1( I, I ) = DCMPLX( DBLE( T1( I, I ) ), ZERO ) 80 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly lower triangular diagonal block of A is copied * to the strictly upper triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 110, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 100, J = II, JJ+JSEC-2 DO 90, I = J+1, II+ISEC-1 T1( J-II+1, I-II+1 ) = DCONJG( A( I, J ) ) 90 CONTINUE 100 CONTINUE 110 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*conjg( A' )*B + C and C := alpha*A*B + C, * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'C', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ZONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ZONE, C( II, 1 ), LDC ) END IF 120 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 180, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 130 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 140, J = 1, JSEC T1( J, J ) = DCMPLX( DBLE( T1( J, J ) ), ZERO ) 140 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly upper triangular diagonal block of A is copied * to the strictly lower triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 170, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 160, I = II+1, JJ+JSEC-1 DO 150, J = II, I-1 T1( I-JJ+1, J-JJ+1 ) = DCONJG( A( J, I ) ) 150 CONTINUE 160 CONTINUE 170 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*conjg( A' ) + C, * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ZONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'C', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ZONE, C( 1, JJ ), LDC ) END IF 180 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 240, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 190, J = JJ, JJ+JSEC-1 CALL ZCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 190 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 200, J = 1, JSEC T1( J, J ) = DCMPLX( DBLE( T1( J, J ) ), ZERO ) 200 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly lower triangular diagonal block of A is copied * to the strictly upper triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 230, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 220, I = JJ, II+ISEC-2 DO 210, J = I+1, JJ+JSEC-1 T1( I-JJ+1, J-JJ+1 ) = DCONJG( A( J, I ) ) 210 CONTINUE 220 CONTINUE 230 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*conjg( A' ) + C, * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ZONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'C', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ZONE, C( 1, JJ ), LDC ) END IF 240 CONTINUE END IF END IF * RETURN * * End of ZGB03. * END SHAR_EOF fi # end of overwriting check if test -f 'zgb04.f' then echo shar: will not over-write existing file "'zgb04.f'" else cat << SHAR_EOF > 'zgb04.f' SUBROUTINE ZGB04 ( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGB04 (ZSYRK) performs one of the symmetric rank k operations * * C := alpha*A*A' + beta*C, * * or * * C := alpha*A'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A is an n by k matrix in the first case and a k by n matrix * in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. * * TRANS = 'T' or 't' C := alpha*A'*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'T' or 't', K specifies the number of rows of the * matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK COMPLEX*16 DELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME, ZGB90, ZGB91 EXTERNAL LSAME, ZGB90, ZGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZGEMV, ZCOPY, ZSCAL * .. Parameters .. COMPLEX*16 ONE, ZERO INTEGER ZIP41, ZIP42 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ), $ ZIP41 = 41, ZIP42 = 42 ) * .. User specified parameters for ZGB04 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 44, RB = 44, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( ( .NOT.NOTR ) ).AND.( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGB04 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL ZSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL ZSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Upper, Notr. * SMALLN = .NOT.ZGB90( ZIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZGB90( ZIP42 , N, K ) DO 110, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 50, I = II, II+ISEC-1 DO 40, L = 1, K CALL ZAXPY ( I-II+1, ALPHA*A( I, L ), $ A( II, L ), 1, C( II, I ), 1 ) 40 CONTINUE 50 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 60, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 60 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 70, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having upper * triangular storage format. * DO 90, I = II, II+ISEC-1 DO 80, L = 1, K CALL ZAXPY ( I-II+1, ALPHA*A( I, L ), $ A( II, L ), 1, T2( 1, I-II+1 ), 1 ) 80 CONTINUE 90 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 100, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 100 CONTINUE END IF 110 CONTINUE ELSE DO 150, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 140, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 120, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 120 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 130, I = II, II+ISEC-1 CALL ZGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 130 CONTINUE DELTA = ONE 140 CONTINUE 150 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Upper, Trans. * SMALLN = .NOT.ZGB90( ZIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZGB90( ZIP42 , N, K ) DO 260, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 160, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, C( II, I ), 1 ) 160 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 180, I = II, II+ISEC-1 DO 170, L = 1, K CALL ZAXPY ( I-II+1, ALPHA*A( L, I ), $ A( L, II ), LDA, C( II, I ), 1 ) 170 CONTINUE 180 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 190, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 190 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 200, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 200 CONTINUE END IF DO 240, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 210, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 210 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * upper triangular storage format. * DO 230, I = II, II+ISEC-1 DO 220, L = LL, LL+LSEC-1 CALL ZAXPY ( I-II+1, $ ALPHA*T3( I-II+1, L-LL+1 ), $ T3( 1, L-LL+1 ), 1, $ T2( 1, I-II+1 ), 1 ) 220 CONTINUE 230 CONTINUE 240 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 250, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 250 CONTINUE END IF 260 CONTINUE ELSE CLDA = ZGB91( LDA ) DO 310, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 300, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 270, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 280 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 290, I = II, II+ISEC-1 CALL ZGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 290 CONTINUE DELTA = ONE 300 CONTINUE 310 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Lower, Notr. * SMALLN = .NOT.ZGB90( ZIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZGB90( ZIP42 , N, K ) DO 400, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 320, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 320 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 340, I = II, II+ISEC-1 DO 330, L = 1, K CALL ZAXPY ( II+ISEC-I, ALPHA*A( I, L ), $ A( I, L ), 1, C( I, I ), 1 ) 330 CONTINUE 340 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 350, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 350 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 360, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 360 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having lower * triangular storage format. * DO 380, I = II, II+ISEC-1 DO 370, L = 1, K CALL ZAXPY ( II+ISEC-I, ALPHA*A( I, L ), $ A( I, L ), 1, T2( I-II+1, I-II+1 ), 1 ) 370 CONTINUE 380 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 390, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 400 CONTINUE ELSE DO 440, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 430, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 410, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 410 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 420, I = II, II+ISEC-1 CALL ZGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 420 CONTINUE DELTA = ONE 430 CONTINUE * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 440 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Lower, Trans. * SMALLN = .NOT.ZGB90( ZIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZGB90( ZIP42 , N, K ) DO 550, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 450, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 450 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 470, I = II, II+ISEC-1 DO 460, L = 1, K CALL ZAXPY ( II+ISEC-I, ALPHA*A( L, I ), $ A( L, I ), LDA, C( I, I ), 1 ) 460 CONTINUE 470 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 480, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 480 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 490, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 490 CONTINUE END IF DO 530, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 500, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 500 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * lower triangular storage format. * DO 520, I = II, II+ISEC-1 DO 510, L = LL, LL+LSEC-1 CALL ZAXPY ( II+ISEC-I, $ ALPHA*T3( I-II+1, L-LL+1 ), $ T3( I-II+1, L-LL+1 ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 510 CONTINUE 520 CONTINUE 530 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 540, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 540 CONTINUE END IF * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 550 CONTINUE ELSE CLDA = ZGB91( LDA ) DO 600, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 590, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 560, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 560 CONTINUE ELSE DO 570, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 570 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 580, I = II, II+ISEC-1 CALL ZGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 580 CONTINUE DELTA = ONE 590 CONTINUE * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 600 CONTINUE END IF END IF END IF * RETURN * * End of ZGB04. * END SHAR_EOF fi # end of overwriting check if test -f 'zgb05.f' then echo shar: will not over-write existing file "'zgb05.f'" else cat << SHAR_EOF > 'zgb05.f' SUBROUTINE ZGB05 ( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGB05 (ZHERK) performs one of the hermitian rank k operations * * C := alpha*A*conjg( A' ) + beta*C, * * or * * C := alpha*conjg( A' )*A + beta*C, * * where alpha and beta are real scalars, C is an n by n hermitian * matrix and A is an n by k matrix in the first case and a k by n * matrix in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. * * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'C' or 'c', K specifies the number of rows of the * matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK COMPLEX*16 ZALPHA, ZBETA, ZDELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX, DBLE, DCMPLX, DCONJG * .. External Functions .. LOGICAL LSAME, ZGB90, ZGB91 EXTERNAL LSAME, ZGB90, ZGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZGEMV, ZHER, ZCOPY, ZSCAL * .. Parameters .. DOUBLE PRECISION ONE, ZERO COMPLEX*16 ZONE INTEGER ZIP51, ZIP52 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ ZONE = ( 1.0D+0, 0.0D+0 ), $ ZIP51 = 51, ZIP52 = 52 ) * .. User specified parameters for ZGB05 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 44, RB = 44, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ), $ T4( CB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGB05 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * ZALPHA = DCMPLX( ALPHA, ZERO ) ZBETA = DCMPLX( BETA, ZERO ) * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN C( 1, 1 ) = DCMPLX( BETA*DBLE( C( 1, 1 ) ), ZERO ) DO 10, I = 2, N CALL ZSCAL ( I-1, ZBETA, C( 1, I ), 1 ) C( I, I ) = DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) 10 CONTINUE ELSE DO 20, I = 1, N-1 C( I, I ) = DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) CALL ZSCAL ( N-I, ZBETA, C( I+1, I ), 1 ) 20 CONTINUE C( N, N ) = DCMPLX( BETA*DBLE( C( N, N ) ), ZERO ) END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*conjg( A' ) + beta*C. Upper, Notr. * SMALLN = .NOT.ZGB90( ZIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZGB90( ZIP52 , N, K ) DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'C', II-1, ISEC, K, ZALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ ZBETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN C( II, II ) = $ DCMPLX( BETA*DBLE( C( II, II ) ), ZERO ) DO 30, I = II+1, II+ISEC-1 CALL ZSCAL ( I-II, ZBETA, C( II, I ), 1 ) C( I, I ) = $ DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) 30 CONTINUE END IF * * C := alpha*A*conjg( A' ) + C, hermitian matrix * multiply. C is a hermitian diagonal block having * upper triangular storage format. * DO 40, L = 1, K CALL ZHER ( 'U', ISEC, ALPHA, A( II, L ), $ 1, C( II, II ), LDC ) 40 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * hermitian matrix C is copied to the upper * triangular part of T2. * DO 50, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 50 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. The imaginary part of the * diagonal elements of T2 are set to ZERO. * IF( BETA.NE.ONE )THEN T2( 1, 1 ) = $ DCMPLX( BETA*DBLE( T2( 1, 1 ) ), ZERO ) DO 60, I = 2, ISEC CALL ZSCAL ( I-1, ZBETA, T2( 1, I ), 1 ) T2( I, I ) = $ DCMPLX( BETA*DBLE( T2( I, I ) ), ZERO ) 60 CONTINUE END IF * * T2 := alpha*A*conjg( A' ) + T2, hermitian matrix * multiply. T2 contains a hermitian block having * upper triangular storage format. * DO 70, L = 1, K CALL ZHER ( 'U', ISEC, ALPHA, A( II, L ), $ 1, T2( 1, 1 ), RCB ) 70 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 80, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 80 CONTINUE END IF 90 CONTINUE ELSE DO 140, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'C', II-1, ISEC, K, ZALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ ZBETA, C( 1, II ), LDC ) END IF ZDELTA = ZBETA DO 130, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 100, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 100 CONTINUE * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 120, I = II, II+ISEC-1 DO 110, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ DCONJG( T1( I-II+1, L-LL+1 ) ) 110 CONTINUE CALL ZGEMV ( 'N', I-II+1, LSEC, ZALPHA, $ T1( 1, 1 ), RB, T4( 1 ), 1, $ ZDELTA, C( II, I ), 1 ) C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 120 CONTINUE ZDELTA = ZONE 130 CONTINUE 140 CONTINUE END IF ELSE * * Form C := alpha*conjg( A' )*A + beta*C. Upper, Trans. * SMALLN = .NOT.ZGB90( ZIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZGB90( ZIP52 , N, K ) DO 250, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'C', 'N', II-1, ISEC, K, ZALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ ZBETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN C( II, II ) = $ DCMPLX( BETA*DBLE( C( II, II ) ), ZERO ) DO 150, I = II+1, II+ISEC-1 CALL ZSCAL ( I-II, ZBETA, C( II, I ), 1 ) C( I, I ) = $ DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) 150 CONTINUE END IF * * C := alpha*conjg( A' )*A + C, hermitian matrix * multiply. C is a hermitian diagonal block having * upper triangular storage format. The local array * T3 is used for temporary storage of the conjugate * transposed vectors of A. * DO 170, L = 1, K DO 160, I = II, II+ISEC-1 T3( I-II+1, 1 ) = DCONJG( A( L, I ) ) 160 CONTINUE CALL ZHER ( 'U', ISEC, ALPHA, T3( 1, 1 ), $ 1, C( II, II ), LDC ) 170 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * hermitian matrix C is copied to the upper * triangular part of T2. * DO 180, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 180 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 190, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, ZBETA, $ T2( 1, I-II+1 ), 1 ) 190 CONTINUE END IF DO 230, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 200, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 200 CONTINUE * * T2 := alpha*conjg( T3' )*T3 + T2, hermitian * matrix multiply. T2 contains a hermitian block * having upper triangular storage format. The * local array T3 is used for temporary storage of * the conjugate transposed vectors of A. * DO 220, L = LL, LL+LSEC-1 DO 210, I = 1, ISEC T3( I, L-LL+1 ) = $ DCONJG( T3( I, L-LL+1 ) ) 210 CONTINUE CALL ZHER ( 'U', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 220 CONTINUE 230 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 240, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 240 CONTINUE END IF 250 CONTINUE ELSE CLDA = ZGB91( LDA ) DO 330, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'C', 'N', II-1, ISEC, K, ZALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ ZBETA, C( 1, II ), LDC ) END IF ZDELTA = ZBETA DO 320, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := conjg( A' ), the conjugated transpose of a * rectangular block of A is copied to T1. * IF( CLDA )THEN DO 270, I = II, II+ISEC-1 DO 260, L = LL, LL+LSEC-1 T1( I-II+1, L-LL+1 ) = $ DCONJG( A( L, I ) ) 260 CONTINUE 270 CONTINUE ELSE DO 290, L = LL, LL+LSEC-1 DO 280, I = II, II+ISEC-1 T1( I-II+1, L-LL+1 ) = $ DCONJG( A( L, I ) ) 280 CONTINUE 290 CONTINUE END IF * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 310, I = II, II+ISEC-1 DO 300, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ DCONJG( T1( I-II+1, L-LL+1 ) ) 300 CONTINUE CALL ZGEMV ( 'N', I-II+1, LSEC, ZALPHA, $ T1( 1, 1 ), RB, T4( 1 ), 1, $ ZDELTA, C( II, I ), 1 ) C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 310 CONTINUE ZDELTA = ZONE 320 CONTINUE 330 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*conjg( A' ) + beta*C. Lower, Notr. * SMALLN = .NOT.ZGB90( ZIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZGB90( ZIP52 , N, K ) DO 400, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 340, I = II, II+ISEC-2 C( I, I ) = $ DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) CALL ZSCAL ( II+ISEC-I-1, ZBETA, $ C( I+1, I ), 1 ) 340 CONTINUE C( II+ISEC-1, II+ISEC-1 ) = $ DCMPLX( BETA*DBLE( C( II+ISEC-1, $ II+ISEC-1 ) ), ZERO ) END IF * * C := alpha*A*conjg( A' ) + C, hermitian matrix * multiply. C is a hermitian diagonal block having * lower triangular storage format. * DO 350, L = 1, K CALL ZHER ( 'L', ISEC, ALPHA, A( II, L ), $ 1, C( II, II ), LDC ) 350 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * hermitian matrix C is copied to the lower * triangular part of T2. * DO 360, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 360 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. The imaginary part of the * diagonal elements of T2 are set to ZERO. * IF( BETA.NE.ONE )THEN DO 370, I = 1, ISEC-1 T2( I, I ) = $ DCMPLX( BETA*DBLE( T2( I, I ) ), ZERO ) CALL ZSCAL ( ISEC-I, ZBETA, $ T2( I+1, I ), 1 ) 370 CONTINUE T2( ISEC, ISEC ) = $ DCMPLX( BETA*DBLE( T2( ISEC, ISEC ) ), $ ZERO ) END IF * * T2 := alpha*A*conjg( A' ) + T2, symmetric matrix * multiply. T2 contains a hermitian block having * lower triangular storage format. * DO 380, L = 1, K CALL ZHER ( 'L', ISEC, ALPHA, A( II, L ), $ 1, T2( 1, 1 ), RCB ) 380 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 390, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ ZALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, ZBETA, C( II+ISEC, II ), LDC ) END IF 400 CONTINUE ELSE DO 450, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 ZDELTA = ZBETA DO 440, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 410, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 410 CONTINUE * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 430, I = II, II+ISEC-1 DO 420, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ DCONJG( T1( I-II+1, L-LL+1 ) ) 420 CONTINUE CALL ZGEMV ( 'N', II+ISEC-I, LSEC, ZALPHA, $ T1( I-II+1, 1 ), RB, T4( 1 ), 1, $ ZDELTA, C( I, I ), 1 ) C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 430 CONTINUE ZDELTA = ZONE 440 CONTINUE * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ ZALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, ZBETA, C( II+ISEC, II ), LDC ) END IF 450 CONTINUE END IF ELSE * * Form C := alpha*conjg( A' )*A + beta*C. Lower, Trans. * SMALLN = .NOT.ZGB90( ZIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZGB90( ZIP52 , N, K ) DO 560, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN DO 460, I = II, II+ISEC-2 C( I, I ) = $ DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) CALL ZSCAL ( II+ISEC-I-1, ZBETA, $ C( I+1, I ), 1 ) 460 CONTINUE C( II+ISEC-1, II+ISEC-1 ) = $ DCMPLX( BETA*DBLE( C( II+ISEC-1, $ II+ISEC-1 ) ), ZERO ) END IF * * C := alpha*conjg( A' )*A + C, hermitian matrix * multiply. C is a hermitian diagonal block having * lower triangular storage format. The local array * T3 is used for temporary storage of the conjugate * transposed vectors of A. * DO 480, L = 1, K DO 470, I = II, II+ISEC-1 T3( I-II+1, 1 ) = DCONJG( A( L, I ) ) 470 CONTINUE CALL ZHER ( 'L', ISEC, ALPHA, T3( 1, 1 ), $ 1, C( II, II ), LDC ) 480 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 490, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 490 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 500, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, ZBETA, $ T2( I-II+1, I-II+1 ), 1 ) 500 CONTINUE END IF DO 540, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 510, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 510 CONTINUE * * T2 := alpha*conjg( T3' )*T3 + T2, hermitian * matrix multiply. T2 contains a hermitian block * having lower triangular storage format. The * local array T3 is used for temporary storage of * the conjugate transposed vectors of A. * DO 530, L = LL, LL+LSEC-1 DO 520, I = 1, ISEC T3( I, L-LL+1 ) = $ DCONJG( T3( I, L-LL+1 ) ) 520 CONTINUE CALL ZHER ( 'L', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 530 CONTINUE 540 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 550, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 550 CONTINUE END IF * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ ZALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, ZBETA, C( II+ISEC, II ), LDC ) END IF 560 CONTINUE ELSE CLDA = ZGB91( LDA ) DO 650, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 ZDELTA = ZBETA DO 640, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := conjg( A' ), the conjugated transpose of a * rectangular block of A is copied to T1. * IF( CLDA )THEN DO 580, I = II, II+ISEC-1 DO 570, L = LL, LL+LSEC-1 T1( I-II+1, L-LL+1 ) = $ DCONJG( A( L, I ) ) 570 CONTINUE 580 CONTINUE ELSE DO 600, L = LL, LL+LSEC-1 DO 590, I = II, II+ISEC-1 T1( I-II+1, L-LL+1 ) = $ DCONJG( A( L, I ) ) 590 CONTINUE 600 CONTINUE END IF * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 630, I = II, II+ISEC-1 DO 620, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ DCONJG( T1( I-II+1, L-LL+1 ) ) 620 CONTINUE CALL ZGEMV ( 'N', II+ISEC-I, LSEC, ZALPHA, $ T1( I-II+1, 1 ), RB, T4( 1 ), 1, $ ZDELTA, C( I, I ), 1 ) C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 630 CONTINUE ZDELTA = ZONE 640 CONTINUE * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ ZALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, ZBETA, C( II+ISEC, II ), LDC ) END IF 650 CONTINUE END IF END IF END IF * RETURN * * End of ZGB05. * END SHAR_EOF fi # end of overwriting check if test -f 'zgb06.f' then echo shar: will not over-write existing file "'zgb06.f'" else cat << SHAR_EOF > 'zgb06.f' SUBROUTINE ZGB06 ( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGB06 (ZSYR2K) performs one of the symmetric rank 2k operations * * C := alpha*A*B' + alpha*B*A' + beta*C, * * or * * C := alpha*A'*B + alpha*B'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A and B are n by k matrices in the first case and k by n * matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + * beta*C. * * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'T' or 't', K specifies the number of rows of the * matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, JJ, JX, JSEC LOGICAL UPPER, NOTR * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZAXPY, ZSCAL * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. User specified parameters for ZGB06 .. INTEGER RCB, CB PARAMETER ( RCB = 80, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND. ( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGB06 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL ZSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL ZSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Upper, Notr. * DO 70, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL ZGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL ZAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by ZAXPY is CB. * DO 60, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 50, I = JJ, II+ISEC-1 CALL ZAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 50 CONTINUE 60 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, BETA, $ C( 1, II ), LDC ) CALL ZGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ONE, $ C( 1, II ), LDC ) END IF 70 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Upper, Trans. * DO 120, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A'*B, general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL ZGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 80, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, C( II, I ), 1 ) 80 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 90, I = II, II+ISEC-1 CALL ZAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 90 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by ZAXPY is CB. * DO 110, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 100, I = JJ, II+ISEC-1 CALL ZAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 100 CONTINUE 110 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, BETA, $ C( 1, II ), LDC ) CALL ZGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( 1, II ), LDA, ONE, $ C( 1, II ), LDC ) END IF 120 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Lower, Notr. * DO 170, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL ZGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 130, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 130 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 140, I = II, II+ISEC-1 CALL ZAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 140 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by ZAXPY is CB. * DO 160, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 150, I = II, JJ+JSEC-1 CALL ZAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 150 CONTINUE 160 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL ZGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ B( II+ISEC, 1 ), LDB, A( II, 1 ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 170 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Lower, Trans. * DO 220, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL ZGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 180, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 180 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 190, I = II, II+ISEC-1 CALL ZAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 190 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by ZAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 CALL ZAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 200 CONTINUE 210 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL ZGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ B( 1, II+ISEC ), LDB, A( 1, II ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 220 CONTINUE END IF END IF * RETURN * * End of ZGB06. * END SHAR_EOF fi # end of overwriting check if test -f 'zgb07.f' then echo shar: will not over-write existing file "'zgb07.f'" else cat << SHAR_EOF > 'zgb07.f' SUBROUTINE ZGB07 ( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC DOUBLE PRECISION BETA COMPLEX*16 ALPHA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGB07 (ZHER2K) performs one of the hermitian rank 2k operations * * C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, * * or * * C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, * * where alpha and beta are scalars with beta real, C is an n by n * hermitian matrix and A and B are n by k matrices in the first case * and k by n matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + * conjg( alpha )*B*conjg( A' ) + * beta*C. * * TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + * conjg( alpha )*conjg( B' )*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'C' or 'c', K specifies the number of rows of the * matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC LOGICAL UPPER, NOTR COMPLEX*16 ZBETA * .. Intrinsic Functions .. INTRINSIC MIN, MAX, DBLE, DCMPLX, DCONJG * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZAXPY, ZSCAL * .. Parameters .. DOUBLE PRECISION ONE, ZERO COMPLEX*16 ZONE, ZZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ ZONE = ( 1.0D+0, 0.0D+0 ), $ ZZERO = ( 0.0D+0, 0.0D+0 ) ) * .. User specified parameters for ZGB07 .. INTEGER RCB, CB PARAMETER ( RCB = 80, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGB07 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * ZBETA = DCMPLX( BETA, ZERO ) * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN C( 1, 1 ) = DCMPLX( BETA*DBLE( C( 1, 1 ) ), ZERO ) DO 10, I = 2, N CALL ZSCAL ( I-1, ZBETA, C( 1, I ), 1 ) C( I, I ) = DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) 10 CONTINUE ELSE DO 20, I = 1, N-1 C( I, I ) = DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) CALL ZSCAL ( N-I, ZBETA, C( I+1, I ), 1 ) 20 CONTINUE C( N, N ) = DCMPLX( BETA*DBLE( C( N, N ) ), ZERO ) END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*conjg( B' ) + * conjg( alpha )*B*conjg( A' ) + beta*C. Upper, Notr. * DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL ZGEMM ( 'N', 'C', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, ZBETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL ZAXPY ( I-II+1, ZONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * lower triangular part of T1 is added to the upper * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by ZAXPY is CB. * DO 70, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 60, I = JJ, II+ISEC-1 DO 50, J = JJ, MIN( JJ+JSEC-1, I ) C( J, I ) = C( J, I ) + $ DCONJG( T1( I-II+1, J-II+1 ) ) 50 CONTINUE 60 CONTINUE 70 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 80, I = II, II+ISEC-1 C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 80 CONTINUE * * C := alpha*A*conjg( B' ) + beta*C and * C := conjg( alpha )*B*conjg( A' ) + C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'C', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, ZBETA, $ C( 1, II ), LDC ) CALL ZGEMM ( 'N', 'C', II-1, ISEC, K, DCONJG( ALPHA ), $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ZONE, $ C( 1, II ), LDC ) END IF 90 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B + * conjg( alpha )*conjg( B' )*A + beta*C. Upper, Trans. * DO 160, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*conjg( A' )*B, matrix multiply on * rectangular blocks of A and B. T1 is a square block. * CALL ZGEMM ( 'C', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 100, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, ZBETA, C( II, I ), 1 ) 100 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 110, I = II, II+ISEC-1 CALL ZAXPY ( I-II+1, ZONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 110 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * lower triangular part of T1 is added to the upper * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by ZAXPY is CB. * DO 140, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 130, I = JJ, II+ISEC-1 DO 120, J = JJ, MIN( JJ+JSEC-1, I ) C( J, I ) = C( J, I ) + $ DCONJG( T1( I-II+1, J-II+1 ) ) 120 CONTINUE 130 CONTINUE 140 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 150, I = II, II+ISEC-1 C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 150 CONTINUE * * C := alpha*conjg( A' )*B + beta*C and * C := alpha*conjg( B' )*A + C, matrix multiply on upper * vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'C', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, ZBETA, $ C( 1, II ), LDC ) CALL ZGEMM ( 'C', 'N', II-1, ISEC, K, DCONJG( ALPHA ), $ B( 1, 1 ), LDB, A( 1, II ), LDA, ZONE, $ C( 1, II ), LDC ) END IF 160 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*conjg( B' ) + * alpha*B*conjg( A' ) + beta*C. Lower, Notr. * DO 230, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL ZGEMM ( 'N', 'C', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 170, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, ZBETA, C( I, I ), 1 ) 170 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 180, I = II, II+ISEC-1 CALL ZAXPY ( II+ISEC-I, ZONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 180 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * upper triangular part of T1 is added to the lower * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by ZAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 DO 190, J = MAX( JJ, I), JJ+JSEC-1 C( J, I ) = C( J, I ) + $ DCONJG( T1( I-II+1, J-II+1 ) ) 190 CONTINUE 200 CONTINUE 210 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 220, I = II, II+ISEC-1 C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 220 CONTINUE * * C := alpha*A*conjg( B' ) + beta*C and * C := alpha*B*conjg( A' ) + C, matrix multiply on lower * vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ ZBETA, C( II+ISEC, II ), LDC ) CALL ZGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ DCONJG( ALPHA ), B( II+ISEC, 1 ), LDB, A( II, 1 ), $ LDA, ZONE, C( II+ISEC, II ), LDC ) END IF 230 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B + * alpha*conjg( B' )*A + beta*C. Lower, Trans. * DO 300, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL ZGEMM ( 'C', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 240, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, ZBETA, C( I, I ), 1 ) 240 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 250, I = II, II+ISEC-1 CALL ZAXPY ( II+ISEC-I, ZONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 250 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * upper triangular part of T1 is added to the lower * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by ZAXPY is CB. * DO 280, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 270, I = II, JJ+JSEC-1 DO 260, J = MAX( JJ, I), JJ+JSEC-1 C( J, I ) = C( J, I ) + $ DCONJG( T1( I-II+1, J-II+1 ) ) 260 CONTINUE 270 CONTINUE 280 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 290, I = II, II+ISEC-1 C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 290 CONTINUE * * C := alpha*conjg( A' )*B + beta*C and * C := alpha*conjg( B' )*A + C, matrix multiply on lower * vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ ZBETA, C( II+ISEC, II ), LDC ) CALL ZGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ DCONJG( ALPHA ), B( 1, II+ISEC ), LDB, A( 1, II ), $ LDA, ZONE, C( II+ISEC, II ), LDC ) END IF 300 CONTINUE END IF END IF * RETURN * * End of ZGB07 . * END SHAR_EOF fi # end of overwriting check if test -f 'zgb08.f' then echo shar: will not over-write existing file "'zgb08.f'" else cat << SHAR_EOF > 'zgb08.f' SUBROUTINE ZGB08 ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC COMPLEX*16 ALPHA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGB08 (ZTRMM) performs one of the matrix-matrix operations * * C := alpha*op( A )*C, or C := alpha*C*op( A ) * * where alpha is a scalar, C is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies C from * the left or right as follows: * * SIDE = 'L' or 'l' C := alpha*op( A )*C. * * SIDE = 'R' or 'r' C := alpha*C*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, and on exit is overwritten by the * transformed matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOCONJ, NOUNIT, $ CLDC, SMALLN, TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC COMPLEX*16 GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD, DCONJG * .. External Functions .. LOGICAL LSAME, ZGB90, ZGB91 EXTERNAL LSAME, ZGB90, ZGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZGEMV, ZTRMV, ZCOPY * .. Parameters .. COMPLEX*16 ZERO, ONE INTEGER ZIP81, ZIP82, ZIP83 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ), $ ZIP81 = 81, ZIP82 = 82, ZIP83 = 83 ) * .. User specified parameters for ZGB08 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 44, RB = 44, CB = 44 ) COMPLEX*16 T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( ( .NOT.NOTR ).AND.( .NOT.NOCONJ ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGB08 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL ZGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*C. Left, Upper, No transpose. * SMALLN = .NOT.ZGB90( ZIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZGB90( ZIP82, M, N ) DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 10, J = 1, N CALL ZTRMV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * C := T3*C, triangular matrix multiply involving * a upper triangular diagonal block of A stored * in T3. * DO 30, J = 1, N CALL ZTRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE DELTA = ALPHA CLDC = ZGB91( LDC ) DO 110, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in ZGEMV that appears if the second * dimension (tsec) is zero. * DO 80, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 110 CONTINUE END IF ELSE * * Form C := alpha*A'*C or C := alpha*conjg( A' )*C. * Left, Upper, Transpose or Conjugated transpose * SMALLN = .NOT.ZGB90( ZIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZGB90( ZIP82, M, N ) DO 150, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( TRANSA, 'N', ISEC, N, 0, ZERO, A, $ LDA, C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C or C := conjg( A' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A. * DO 120, J = 1, N CALL ZTRMV ( 'U', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 130 CONTINUE * * C := T3'*C or C := conjg( T3' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A stored in T3. * DO 140, J = 1, N CALL ZTRMV ( 'U', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL ZGEMM ( TRANSA, 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 150 CONTINUE ELSE DELTA = ALPHA CLDC = ZGB91( LDC ) DO 240, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * upper triangular diagonal block of A is copied to * the upper triangular part of T2. * IF( NOCONJ )THEN DO 160, J = II+OFFD, II+ISEC-1 CALL ZCOPY ( J-II+1-OFFD, A( II, J ), 1, $ T2( 1, J-II+1 ), 1 ) 160 CONTINUE ELSE DO 180, J = II+OFFD, II+ISEC-1 DO 170, I = II, J-OFFD T2( I-II+1, J-II+1 ) = DCONJG( A( I, J ) ) 170 CONTINUE 180 CONTINUE END IF DO 230, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 190, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 190 CONTINUE ELSE DO 200, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 200 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 210, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 210 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 220, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 220 CONTINUE 230 CONTINUE * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL ZGEMM ( TRANSA, 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 240 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*C. Left, Lower, No transpose. * SMALLN = .NOT.ZGB90( ZIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZGB90( ZIP82, M, N ) DO 280, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 250, J = 1, N CALL ZTRMV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 250 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. * DO 260, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 260 CONTINUE * * C := T3*C, triangular matrix multiply involving * a lower triangular diagonal block of A stored * in T3. * DO 270, J = 1, N CALL ZTRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 270 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 280 CONTINUE ELSE DELTA = ALPHA CLDC = ZGB91( LDC ) DO 350, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 290, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 290 CONTINUE DO 340, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 300, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 300 CONTINUE ELSE DO 310, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in ZGEMV that appears if the second * dimension (tsec) is zero. * DO 320, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 320 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 330, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 330 CONTINUE 340 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 350 CONTINUE END IF ELSE * * Form C := alpha*A'*C or C := alpha*conjg( A' )*C. * Left, Lower, Transpose or Conjugated transpose * SMALLN = .NOT.ZGB90( ZIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZGB90( ZIP82, M, N ) DO 390, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( TRANSA, 'N', ISEC, N, 0, ZERO, A, $ LDA, C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C or C := conjg( A' )*C, triangular * matrix multiply involving a lower triangular * diagonal block of A. * DO 360, J = 1, N CALL ZTRMV ( 'L', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 360 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to part of T3. * DO 370, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 370 CONTINUE * * C := T3'*C or C := conjg( T3' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A stored in T3. * DO 380, J = 1, N CALL ZTRMV ( 'L', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 380 CONTINUE END IF * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 390 CONTINUE ELSE DELTA = ALPHA CLDC = ZGB91( LDC ) DO 480, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A or T2 := conjg( A ), a unit or non-unit * lower triangular diagonal block of A is copied to * the lower triangular part of T2. * IF( NOCONJ )THEN DO 400, J = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-II+1+OFFD, J-II+1 ), 1 ) 400 CONTINUE ELSE DO 420, J = II, II+ISEC-1-OFFD DO 410, I = J+OFFD, II+ISEC-1 T2( I-II+1, J-II+1 ) = DCONJG( A( I, J ) ) 410 CONTINUE 420 CONTINUE END IF DO 470, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 430, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 430 CONTINUE ELSE DO 440, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 440 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 450, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 450 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 460, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 480 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*C*A. Right, Upper, No transpose. * TINYM = .NOT.ZGB90( ZIP83, M, N ) IF( TINYM )THEN DO 500, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 490, I = 1, M CALL ZTRMV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 500 CONTINUE ELSE DELTA = ALPHA DO 540, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) DO 530, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 510, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 510 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 520, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, C( II, J ), 1 ) 520 CONTINUE 530 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 540 CONTINUE END IF ELSE * * Form C := alpha*C*A' or C := alpha*C*conjg( A' ). * Right, Upper, Transpose or Conjugated transpose. * TINYM = .NOT.ZGB90( ZIP83, M, N ) IF( TINYM )THEN DO 570, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', TRANSA, M, JSEC, 0, ZERO, C, $ LDC, A, LDA, ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T3. * DO 550, J = JJ+OFFD, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T3( J-JJ+1, 1 ), RCB ) 550 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a upper triangular * diagonal block of T3. * DO 560, I = 1, M CALL ZTRMV ( 'L', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 560 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 570 CONTINUE ELSE DELTA = ALPHA DO 640, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit upper triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 580, J = JJ+OFFD, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 580 CONTINUE ELSE DO 600, J = JJ+OFFD, JJ+JSEC-1 DO 590, I = JJ, J-OFFD T2( J-JJ+1, I-JJ+1 ) = DCONJG( A( I, J ) ) 590 CONTINUE 600 CONTINUE END IF DO 630, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 610, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 610 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 620, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 620 CONTINUE 630 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 640 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*C*A. Right, Lower, No transpose. * TINYM = .NOT.ZGB90( ZIP83, M, N ) IF( TINYM )THEN DO 660, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * lower triangular diagonal block of A. * DO 650, I = 1, M CALL ZTRMV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 650 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 660 CONTINUE ELSE DELTA = ALPHA DO 700, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 DO 690, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 670, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 670 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 680, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, C( II, J ), 1 ) 680 CONTINUE 690 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 700 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Lower, Transpose. * TINYM = .NOT.ZGB90( ZIP83, M, N ) IF( TINYM )THEN DO 730, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', TRANSA, M, JSEC, 0, ZERO, C, $ LDC, A, LDA, ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T3. * DO 710, J = JJ, JJ+JSEC-1-OFFD CALL ZCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T3( J-JJ+1, J-JJ+1+OFFD ), RCB ) 710 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a lower triangular * diagonal block of T3. * DO 720, I = 1, M CALL ZTRMV ( 'U', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 720 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a lower triangular * diagonal block of T3. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', TRANSA, M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 730 CONTINUE ELSE DELTA = ALPHA DO 800, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit lower triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 740, J = JJ, JJ+JSEC-1-OFFD CALL ZCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 740 CONTINUE ELSE DO 760, J = JJ, JJ+JSEC-1-OFFD DO 750, I = J+OFFD, JJ+JSEC-1 T2( J-JJ+1, I-JJ+1 ) = DCONJG( A( I, J ) ) 750 CONTINUE 760 CONTINUE END IF DO 790, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 770, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 770 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 780, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 780 CONTINUE 790 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', TRANSA, M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 800 CONTINUE END IF END IF END IF END IF * RETURN * * End of ZGB08. * END SHAR_EOF fi # end of overwriting check if test -f 'zgb09.f' then echo shar: will not over-write existing file "'zgb09.f'" else cat << SHAR_EOF > 'zgb09.f' SUBROUTINE ZGB09 ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC COMPLEX*16 ALPHA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGB09 (ZTRSM) solves one of the matrix equations * * op( A )*X = alpha*C, or X*op( A ) = alpha*C, * * where alpha is a scalar, X and C are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * The matrix X is overwritten on C. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*C. * * SIDE = 'R' or 'r' X*op( A ) = alpha*C. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the right-hand side matrix C, and on exit is * overwritten by the solution matrix X. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOCONJ, NOUNIT, $ CLDC, SMALLN, TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC COMPLEX*16 GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD, DCONJG * .. External Functions .. LOGICAL LSAME, ZGB90, ZGB91 EXTERNAL LSAME, ZGB90, ZGB91 * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZGEMV, ZTRSV, ZCOPY * .. Parameters .. COMPLEX*16 ZERO, ONE INTEGER ZIP91, ZIP92, ZIP93 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ), $ ZIP91 = 91, ZIP92 = 92, ZIP93 = 93 ) * .. User specified parameters for ZGB09 .. INTEGER RB, CB, RCB PARAMETER ( RCB = 7, RB = 5, CB = 3 ) COMPLEX*16 T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( ( .NOT.NOTR ).AND.( .NOT.NOCONJ ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGB09 ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL ZGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Upper, No transpose. * SMALLN = .NOT.ZGB90( ZIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZGB90( ZIP92, M, N ) DO 40, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a upper triangular diagonal block of A. The * block of X is overwritten on C. * DO 10, J = 1, N CALL ZTRSV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * Solve T3*X = C, triangular system solve * involving a upper triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 30, J = 1, N CALL ZTRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF 40 CONTINUE ELSE DELTA = ONE CLDC = ZGB91( LDC ) DO 110, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 80, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = II+ISEC-1-I TIJ = 1 IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE 110 CONTINUE END IF ELSE * * Solve A'*X = alpha*C or conjg( A' )*X = alpha*C. * Left, Upper, Transpose or Conjugated transpose. * SMALLN = .NOT.ZGB90( ZIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZGB90( ZIP92, M, N ) DO 150, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL ZGEMM ( TRANSA, 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C or conjg( A' )*X = C, * triangular system solve involving a upper * triangular diagonal block of A. The block of X * is overwritten on C. * DO 120, J = 1, N CALL ZTRSV ( 'U', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A, a unit or non-unit triangular diagonal * block of A is copied to T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 130 CONTINUE * * Solve T3'*X = C or conjg( T3' )*X = C, * triangular system solve involving a upper * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 140, J = 1, N CALL ZTRSV ( 'U', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF 150 CONTINUE ELSE DELTA = ONE CLDC = ZGB91( LDC ) DO 240, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL ZGEMM ( TRANSA, 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * upper triangular diagonal block of A is copied to * the upper triangular part of T2. * IF( NOCONJ )THEN DO 160, J = II+OFFD, II+ISEC-1 CALL ZCOPY ( J-II+1-OFFD, A( II, J ), 1, $ T2( 1, J-II+1 ), 1 ) 160 CONTINUE ELSE DO 180, J = II+OFFD, II+ISEC-1 DO 170, I = II, J-OFFD T2( I-II+1, J-II+1 ) = DCONJG( A( I, J ) ) 170 CONTINUE 180 CONTINUE END IF DO 230, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 190, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 190 CONTINUE ELSE DO 200, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 200 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 210, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 210 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 220, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 220 CONTINUE 230 CONTINUE 240 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Lower, No transpose. * SMALLN = .NOT.ZGB90( ZIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZGB90( ZIP92, M, N ) DO 280, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a lower triangular diagonal block of A. The * block of X is overwritten on C. * DO 250, J = 1, N CALL ZTRSV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 250 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. The block of X is * overwritten on C. * DO 260, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 260 CONTINUE * * Solve T3*X = C, triangular system solve * involving a lower triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 270, J = 1, N CALL ZTRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 270 CONTINUE END IF 280 CONTINUE ELSE DELTA = ONE CLDC = ZGB91( LDC ) DO 350, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 290, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 290 CONTINUE DO 340, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 300, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 300 CONTINUE ELSE DO 310, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 320, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 320 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 330, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 330 CONTINUE 340 CONTINUE 350 CONTINUE END IF ELSE * * Solve A'*X = alpha*C or conjg( A' )*X = alpha*C. * Left, Lower, Transpose or Conjugated transpose. * SMALLN = .NOT.ZGB90( ZIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZGB90( ZIP92, M, N ) DO 390, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C or conjg( A' )*X = C, * triangular system solve involving a lower * triangular diagonal block of A. The block of X * is overwritten on C. * DO 360, J = 1, N CALL ZTRSV ( 'L', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 360 CONTINUE ELSE * * T3 := A, a unit or non-unit triangular diagonal * block of A is copied to T3. * DO 370, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 370 CONTINUE * * Solve T3'*X = C or conjg( T3' )*X = C, * triangular system solve involving a lower * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 380, J = 1, N CALL ZTRSV ( 'L', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 380 CONTINUE END IF 390 CONTINUE ELSE DELTA = ONE CLDC = ZGB91( LDC ) DO 480, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * lower triangular diagonal block of A is copied to * the lower triangular part of T2. * IF( NOCONJ )THEN DO 400, J = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-II+1+OFFD, J-II+1 ), 1 ) 400 CONTINUE ELSE DO 420, J = II, II+ISEC-1-OFFD DO 410, I = J+OFFD, II+ISEC-1 T2( I-II+1, J-II+1 ) = DCONJG( A( I, J ) ) 410 CONTINUE 420 CONTINUE END IF DO 470, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 430, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 430 CONTINUE ELSE DO 440, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 440 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 450, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 450 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 460, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE 480 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Upper, No transpose. * TINYM = .NOT.ZGB90( ZIP93, M, N ) IF( TINYM )THEN DO 500, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a upper triangular diagonal block of A. The block * of X is overwritten on C. * DO 490, I = 1, M CALL ZTRSV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE 500 CONTINUE ELSE DELTA = ONE DO 550, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 540, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 510, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 510 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 520, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 520 CONTINUE * * C := T1, T1 is copied back to C. * DO 530, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 530 CONTINUE 540 CONTINUE 550 CONTINUE END IF ELSE * * Solve X*A' = alpha*C or X*conjg( A' ) = alpha*C. * Right, Upper, Transpose or Conjugated transpose. * TINYM = .NOT.ZGB90( ZIP93, M, N ) IF( TINYM )THEN DO 580, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to T3. * DO 560, J = JJ+OFFD, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T3( J-JJ+1, 1 ), RCB ) 560 CONTINUE * * Solve X*T3' = C or X*conjg( T3' ) = C, triangular * system solve involving the transpose of a upper * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 570, I = 1, M CALL ZTRSV ( 'L', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 570 CONTINUE 580 CONTINUE ELSE DELTA = ONE DO 660, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit upper triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 590, J = JJ+OFFD, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 590 CONTINUE ELSE DO 610, J = JJ+OFFD, JJ+JSEC-1 DO 600, I = JJ, J-OFFD T2( J-JJ+1, I-JJ+1 ) = DCONJG( A( I, J ) ) 600 CONTINUE 610 CONTINUE END IF DO 650, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 620, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 620 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 630, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 630 CONTINUE * * C := T1, T1 is copied back to C. * DO 640, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 640 CONTINUE 650 CONTINUE 660 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Lower, No transpose. * TINYM = .NOT.ZGB90( ZIP93, M, N ) IF( TINYM )THEN DO 680, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a lower triangular diagonal block of A. The block * of X is overwritten on C. * DO 670, I = 1, M CALL ZTRSV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 670 CONTINUE 680 CONTINUE ELSE DELTA = ONE DO 730, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 720, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 690, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 690 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 700, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 700 CONTINUE * * C := T1, T1 is copied back to C. * DO 710, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 710 CONTINUE 720 CONTINUE 730 CONTINUE END IF ELSE * * Solve X*A' = alpha*C or X*conjg( A' ) = alpha*C. * Right, Lower, Transpose or Conjugated transpose. * TINYM = .NOT.ZGB90( ZIP93, M, N ) IF( TINYM )THEN DO 760, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL ZGEMM ( 'N', TRANSA, M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to T3. * DO 740, J = JJ, JJ+JSEC-1-OFFD CALL ZCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T3( J-JJ+1, J-JJ+1+OFFD ), RCB ) 740 CONTINUE * * Solve X*T3' = C or X*conjg( T3' ) = C, triangular * system solve involving the transpose of a lower * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 750, I = 1, M CALL ZTRSV ( 'U', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 750 CONTINUE 760 CONTINUE ELSE DELTA = ONE DO 840, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL ZGEMM ( 'N', TRANSA, M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit lower triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 770, J = JJ, JJ+JSEC-1-OFFD CALL ZCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 770 CONTINUE ELSE DO 790, J = JJ, JJ+JSEC-1-OFFD DO 780, I = J+OFFD, JJ+JSEC-1 T2( J-JJ+1, I-JJ+1 ) = DCONJG( A( I, J ) ) 780 CONTINUE 790 CONTINUE END IF DO 830, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 800, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 800 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 810, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 810 CONTINUE * * C := T1, T1 is copied back to C. * DO 820, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 820 CONTINUE 830 CONTINUE 840 CONTINUE END IF END IF END IF END IF * RETURN * * End of ZGB09. * END SHAR_EOF fi # end of overwriting check if test -f 'zgb90.f' then echo shar: will not over-write existing file "'zgb90.f'" else cat << SHAR_EOF > 'zgb90.f' LOGICAL FUNCTION ZGB90 ( IP, DIM1, DIM2 ) * .. Scalar Arguments .. INTEGER IP, DIM1, DIM2 * .. * * Purpose * ======= * * ZGB90 determines which of two alternative code sections in a GEMM- * Based Level 3 BLAS routine that will be the fastest for a particular * problem. If the problem is considered large enough ZGB90 returns * .TRUE., otherwise .FALSE. is returned. The input parameter IP * specifies the calling routine and a break point for alternative code * sections. The input parameters DIM1 and DIM2 are matrix dimensions. * The returned value is a function of the input parameters and the * performance characteristics of the two alternative code sections. * * In this simple implementation, the returned values are determined by * looking at only one of the two dimensions DIM1 and DIM2. It may be * rewarding to rewrite the logical expressions in ZGB90 so that both * dimensions are involved. The returned values should effectively * reflect the performance characteristics of the underlying BLAS * routines. * * * Input * ===== * * IP - INTEGER * On entry, IP specifies which routine and which alternative * code sections that the decision is intended for. * Unchanged on exit. * * DIM1 - INTEGER. * On entry, DIM1 specifies the first dimension in the calling * sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * DIM2 - INTEGER. * On entry, DIM2 specifies the second dimension in the * calling sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. User specified parameters for ZGB90 .. INTEGER ZIP41, ZIP42, $ ZIP51, ZIP52, $ ZIP81, ZIP82, ZIP83, $ ZIP91, ZIP92, ZIP93 PARAMETER ( ZIP41 = 4, ZIP42 = 3, $ ZIP51 = 4, ZIP52 = 3, $ ZIP81 = 4, ZIP82 = 3, ZIP83 = 4, $ ZIP91 = 4, ZIP92 = 3, ZIP93 = 4 ) * .. * .. Executable Statements .. IF( IP.EQ.41 )THEN ZGB90 = DIM1.GE.ZIP41 ELSE IF( IP.EQ.42 )THEN ZGB90 = DIM2.GE.ZIP42 ELSE IF( IP.EQ.51 )THEN ZGB90 = DIM1.GE.ZIP51 ELSE IF( IP.EQ.52 )THEN ZGB90 = DIM2.GE.ZIP52 ELSE IF( IP.EQ.81 )THEN ZGB90 = DIM2.GE.ZIP81 ELSE IF( IP.EQ.82 )THEN ZGB90 = DIM2.GE.ZIP82 ELSE IF( IP.EQ.83 )THEN ZGB90 = DIM1.GE.ZIP83 ELSE IF( IP.EQ.91 )THEN ZGB90 = DIM2.GE.ZIP91 ELSE IF( IP.EQ.92 )THEN ZGB90 = DIM2.GE.ZIP92 ELSE IF( IP.EQ.93 )THEN ZGB90 = DIM1.GE.ZIP93 ELSE ZGB90 = .FALSE. END IF * RETURN * * End of ZGB90. * END SHAR_EOF fi # end of overwriting check if test -f 'zgb91.f' then echo shar: will not over-write existing file "'zgb91.f'" else cat << SHAR_EOF > 'zgb91.f' LOGICAL FUNCTION ZGB91 ( LD ) * .. Scalar Arguments .. INTEGER LD * .. * * Purpose * ======= * * The size of the leading dimension of a two-dimensional array may * cause severe problems. Often when an array with a 'critical' leading * dimension is referenced, the execution time becomes significantly * longer than expected. This is caused by shortcomings of the memory * system. * * The function ZGB91 returns .TRUE. if the leading dimension LD is * critical and .FALSE. if it is not critical. In this implementation * ZGB91 is designed to detect critical leading dimensions in an * environment with a multi-way associative cache. Parameters defining * cache characteristics are adjustable to match different machines. * It may be rewarding to rewrite ZGB91 for a machine with a different * cache policy. * * The cache lines in a multi-way associative cache are divided among a * number of partitions, each containing the same number of lines. Each * address of main memory is mapped into a particular partition. The * number of lines in a partition equals the associativity. For example, * in a four way associative cache, each partition contain four cache * lines. * * Data are transferred between the cache and main memory according to * an associative mapping scheme. A transfer of a data word from main * memory to cache is accomplished as follows. A unit of data * (data line) in main memory, with the size of a cache line, and * containing several contiguous data words including the referenced * one, is mapped (copied) to a certain partition in the cache memory. * The partition is determined by the location of the element in the * main memory and the associative mapping scheme. A replacement * algorithm makes room for the data line in one of the cache lines in * the selected partition. For example, an LRU-based (Least Recently * Used) replacement algorithm places the data line in the least * recently 'touched' cache line in the selected partition. * * * Input * ===== * * LD - On entry, LD specifies the leading dimension of a * 2-dimensional array. Unchanged on exit. * * * User specified parameters for ZGB91 * ================================ * * LNSZ - Size of a cache line in number of bytes. * * NPRT - Number of partitions in the cache memory. * * PRTSZ - The number of cache lines in a partition that can be used * exclusively to hold a local array containing a matrix block * during the execution of a GEMM-Based Level 3 BLAS routine. * The remaining cache lines may be occupied by scalars, * vectors and possibly program code depending on the system. * * LOLIM - Leading dimensions smaller than or equal to LOLIM are not * considered critical. * * ZP - Number of bytes in a double complex-precision word. * * * Local Variables and Parameters * ============================== * * ONEWAY - The maximum number of double precision words that can be * stored in the cache memory if only a single cache line in * each partition may be used. * * UPDIF - The difference between the multiple of LD that is nearest * ONEWAY, or nearest a multiple of ONEWAY, and the nearest * multiple of ONEWAY that is larger than LD. In number of * double precision words. * * MXDIF - If both UPDIF and LD - UPDIF are less than MXDIF, and LD * is greater than LOLIM, then the leading dimension is * considered critical. Otherwise, the leading dimension is * considered not critical. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Variables .. INTEGER UPDIF * .. Intrinsic Functions .. INTRINSIC MIN, MOD * .. User specified parameters for ZGB91 .. INTEGER LOLIM, LNSZ, NPRT, PRTSZ, ZP PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 32, ZP = 16 ) * .. Parameters .. INTEGER ONEWAY, MXDIF PARAMETER ( ONEWAY = ( LNSZ*NPRT )/ZP, $ MXDIF = LNSZ/( ZP*PRTSZ ) ) * .. * .. Executable Statements .. * IF( LD.LE.LOLIM )THEN ZGB91 = .FALSE. ELSE UPDIF = MOD( ( LD/ONEWAY )*ONEWAY+ONEWAY, LD ) ZGB91 = MIN( UPDIF, LD-UPDIF ).LE.MXDIF END IF * RETURN * * End of ZGB91. * END SHAR_EOF fi # end of overwriting check if test -f 'zgbt01.f' then echo shar: will not over-write existing file "'zgbt01.f'" else cat << SHAR_EOF > 'zgbt01.f' SUBROUTINE ZGBT01( ZB3LIB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXTRNS, MXDIM, MXLDA, RUNS, RES ) * .. Scalar Arguments .. CHARACTER ZB3LIB INTEGER LD, NMAX, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS COMPLEX*16 ALPHA, BETA * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXTRNS ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) COMPLEX*16 A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ) DOUBLE PRECISION RES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, MXDIM, $ MXLDA ) * * * Time all routines except ZGEMM in the Level 3 BLAS library specified * by the input parameters. The library is either a user-supplied * Level 3 BLAS library or the GEMM-Based Level 3 BLAS library included * in the benchmark (ZGB02, ZGB04, ZGB04, ZGB05, ZGB06, ZGB07, ZGB08, * and ZGB09). Return the performance in Mflops for each problem * configuration. * * ZGBT01 calls a DOUBLE PRECISION function DSECND with no arguments, * which is assumed to return the user time for a process in seconds * from some fixed starting-time. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, J, M, N, K, ADDS, MULTS, NOPS, $ D, L, R, OP1, OP2, OP3, OP4 DOUBLE PRECISION TIME, SPEED, TM0, TM1, TM2, TM3, TM4, TM5, TM6, $ TM7, TM8, TM9, TM10, TM11, TM12, TM13, TM14, $ TM15, TM16, TM17 * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, MIN * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DSECND EXTERNAL LSAME, DSECND * .. External Subroutines .. EXTERNAL ZSYMM, ZHEMM, ZSYRK, ZHERK, ZSYR2K, ZHER2K, $ ZTRMM, ZTRSM, $ ZGB02, ZGB03, ZGB04, ZGB05, ZGB06, ZGB07, $ ZGB08, ZGB09 * .. Parameters .. DOUBLE PRECISION ZERO, SCALE COMPLEX*16 Z11 * .. Parameter Values .. PARAMETER ( ZERO = 0.0D+0, SCALE = 1.0D+6, $ Z11 = ( 1.0D+0, 1.0D+0 ) ) * .. * .. Executable Statements .. TM0 = DSECND( ) TM0 = DSECND( ) TM0 = DSECND( ) TM1 = DSECND( ) * * ------ Stop indentation ------ * DO 390, L = 1, NLDA DO 380, OP1 = 1, NSIDE DO 370, OP2 = 1, NUPLO DO 360, OP3 = 1, NTRNS DO 350, OP4 = 1, NDIAG DO 340, D = 1, NDIM * * ------ Continue indentation ------ * RES( 1, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 2, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 3, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 4, OP1, OP2, OP3, OP4, D, L ) = ZERO RES( 5, OP1, OP2, OP3, OP4, D, L ) = ZERO DO 330, R = 1, RUNS IF( LSAME( ZB3LIB, 'U' ) )THEN * * Time the user-supplied library. Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 20, J = 1, NMAX DO 10, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 10 CONTINUE 20 CONTINUE TM2 = DSECND( ) CALL ZSYMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM3 = DSECND( ) END IF IF( TABSUB( 2 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 40, J = 1, NMAX DO 30, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 30 CONTINUE 40 CONTINUE TM4 = DSECND( ) CALL ZHEMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM5 = DSECND( ) END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 60, J = 1, NMAX DO 50, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 50 CONTINUE 60 CONTINUE TM6 = DSECND( ) CALL ZSYRK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), $ BETA, C, LDA( L ) ) TM7 = DSECND( ) END IF IF( TABSUB( 4 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 80, J = 1, NMAX DO 70, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 70 CONTINUE 80 CONTINUE TM8 = DSECND( ) CALL ZHERK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), DBLE( ALPHA ), A, LDA( L ), $ DBLE( BETA ), C, LDA( L ) ) TM9 = DSECND( ) END IF IF( TABSUB( 5 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 100, J = 1, NMAX DO 90, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 90 CONTINUE 100 CONTINUE TM10 = DSECND( ) CALL ZSYR2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM11 = DSECND( ) END IF IF( TABSUB( 6 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 120, J = 1, NMAX DO 110, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 110 CONTINUE 120 CONTINUE TM12 = DSECND( ) CALL ZHER2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ DBLE( BETA ), C, LDA( L ) ) TM13 = DSECND( ) END IF IF( TABSUB( 7 ) )THEN DO 140, J = 1, NMAX DO 130, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 130 CONTINUE 140 CONTINUE TM14 = DSECND( ) CALL ZTRMM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM15 = DSECND( ) END IF IF( TABSUB( 8 ) )THEN DO 160, J = 1, NMAX DO 150, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 150 CONTINUE 160 CONTINUE TM16 = DSECND( ) CALL ZTRSM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM17 = DSECND( ) END IF ELSE IF( LSAME( ZB3LIB, 'G' ) )THEN * * Time the built-in GEMM-Based Level 3 BLAS library (DGB02, * DGB04, DGB06, DGB08, and DGB09). Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 180, J = 1, NMAX DO 170, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 170 CONTINUE 180 CONTINUE TM2 = DSECND( ) CALL ZGB02( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM3 = DSECND( ) END IF IF( TABSUB( 2 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN DO 200, J = 1, NMAX DO 190, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 190 CONTINUE 200 CONTINUE TM4 = DSECND( ) CALL ZGB03( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM5 = DSECND( ) END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 220, J = 1, NMAX DO 210, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 210 CONTINUE 220 CONTINUE TM6 = DSECND( ) CALL ZGB04( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), $ BETA, C, LDA( L ) ) TM7 = DSECND( ) END IF IF( TABSUB( 4 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 240, J = 1, NMAX DO 230, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 230 CONTINUE 240 CONTINUE TM8 = DSECND( ) CALL ZGB05( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), DBLE( ALPHA ), A, LDA( L ), $ DBLE( BETA ), C, LDA( L ) ) TM9 = DSECND( ) END IF IF( TABSUB( 5 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 260, J = 1, NMAX DO 250, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 250 CONTINUE 260 CONTINUE TM10 = DSECND( ) CALL ZGB06( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ BETA, C, LDA( L ) ) TM11 = DSECND( ) END IF IF( TABSUB( 6 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 280, J = 1, NMAX DO 270, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 270 CONTINUE 280 CONTINUE TM12 = DSECND( ) CALL ZGB07( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), $ DIM2( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ DBLE( BETA ), C, LDA( L ) ) TM13 = DSECND( ) END IF IF( TABSUB( 7 ) )THEN DO 300, J = 1, NMAX DO 290, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 290 CONTINUE 300 CONTINUE TM14 = DSECND( ) CALL ZGB08( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM15 = DSECND( ) END IF IF( TABSUB( 8 ) )THEN DO 320, J = 1, NMAX DO 310, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 310 CONTINUE 320 CONTINUE TM16 = DSECND( ) CALL ZGB09( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), $ DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, $ A, LDA( L ), C, LDA( L ) ) TM17 = DSECND( ) END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown Level 3 BLAS library choosen: ', ZB3LIB, '.' END IF * * Compute the performance of ZSYMM in Mflops. * IF( TABSUB( 1 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM3 - TM2 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN MULTS = ( M + 1 )*M*N + MIN( M*N, ( M*( M+1 ) )/2 ) ADDS = M*M*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN MULTS = ( N + 1 )*M*N + MIN( M*N, ( N*( N+1 ) )/2 ) ADDS = M*N*N NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 1, OP1, OP2, 1, 1, D, L ).LT.SPEED )THEN RES( 1, OP1, OP2, 1, 1, D, L ) = SPEED END IF END IF * * Compute the performance of ZHEMM in Mflops. * IF( TABSUB( 2 ).AND.OP3.EQ.1.AND.OP4.EQ.1 )THEN TIME = ( TM5 - TM4 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN MULTS = ( 6*M + 2 )*M*N + MIN( 6*M*N, 3*M*M - M ) ADDS = 2*M*M*N NOPS = MULTS + ADDS ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN MULTS = ( 6*N + 2 )*M*N + MIN( 6*M*N, 3*N*N - N ) ADDS = 2*M*N*N NOPS = MULTS + ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 2, OP1, OP2, 1, 1, D, L ).LT.SPEED )THEN RES( 2, OP1, OP2, 1, 1, D, L ) = SPEED END IF END IF * * Compute the performance of ZSYRK in Mflops. * IF( TABSUB( 3 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN TIME = ( TM7 - TM6 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( K + 1 )*( N*( N+1 )/2 ) + MIN( N*K, N*( N+1 )/2 ) ADDS = K*( N*( N+1 )/2 ) NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 3, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 3, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of ZHERK in Mflops. * IF( TABSUB( 4 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN TIME = ( TM9 - TM8 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( 3*K + 1 )*N*N + MIN( 2*N*K, N*N ) ADDS = K*N*N NOPS = MULTS + ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 4, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 4, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of ZSYR2K in Mflops. * IF( TABSUB( 5 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN TIME = ( TM11 - TM10 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( 2*K + 1 )*( N*( N+1 )/2 ) + $ MIN( 2*N*K, N*( N+1 ) ) ADDS = K*N*( N+1 ) NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 5, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 5, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of ZHER2K in Mflops. * IF( TABSUB( 6 ).AND.OP1.EQ.1.AND.OP4.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN TIME = ( TM13 - TM12 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( 6*K + 1 )*N*N + MIN( 12*N*K, 6*N*N - 2*N ) ADDS = 2*K*N*N NOPS = MULTS + ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 6, 1, OP2, OP3, 1, D, L ).LT.SPEED )THEN RES( 6, 1, OP2, OP3, 1, D, L ) = SPEED END IF END IF * * Compute the performance of ZTRMM in Mflops. * IF( TABSUB( 7 ) )THEN TIME = ( TM15 - TM14 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN MULTS = ( ( M*( M + 1 ) )/2 )*N + $ MIN( M*N, ( M*( M + 1 ) )/2 ) ADDS = ( ( M*( M - 1 ) )/2 )*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN MULTS = ( ( M*( M - 1 ) )/2 )*N + $ MIN( M*N, ( M*( M + 1 ) )/2 ) ADDS = ( ( M*( M - 1 ) )/2 )*N NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN MULTS = ( M*( N*( N + 1 ) )/2 ) + $ MIN( M*N, ( N*( N + 1 ) )/2 ) ADDS = M*( N*( N - 1 ) )/2 NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN MULTS = ( M*( N*( N - 1 ) )/2 ) + $ MIN( M*N, ( N*( N + 1 ) )/2 ) ADDS = M*( N*( N - 1 ) )/2 NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 7, OP1, OP2, OP3, OP4, D, L ).LT.SPEED )THEN RES( 7, OP1, OP2, OP3, OP4, D, L ) = SPEED END IF END IF * * Compute the performance of ZTRSM in Mflops. * IF( TABSUB( 8 ) )THEN TIME = ( TM17 - TM16 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN MULTS = ( ( M*( M + 1 ) )/2 )*N + $ MIN( M*N, ( M*( M + 1 ) )/2 ) ADDS = ( ( M*( M - 1 ) )/2 )*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN MULTS = ( ( M*( M - 1 ) )/2 )*N + $ MIN( M*N, ( M*( M + 1 ) )/2 ) ADDS = ( ( M*( M - 1 ) )/2 )*N NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN IF( LSAME( DIAG( OP4 ), 'N' ) )THEN MULTS = ( M*( N*( N + 1 ) )/2 ) + $ MIN( M*N, ( N*( N + 1 ) )/2 ) ADDS = M*( N*( N - 1 ) )/2 NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( DIAG( OP4 ), 'U' ) )THEN MULTS = ( M*( N*( N - 1 ) )/2 ) + $ MIN( M*N, ( N*( N + 1 ) )/2 ) ADDS = M*( N*( N - 1 ) )/2 NOPS = 6*MULTS + 2*ADDS ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for DIAG: ', DIAG( OP4 ), '.' END IF ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 8, OP1, OP2, OP3, OP4, D, L ).LT.SPEED )THEN RES( 8, OP1, OP2, OP3, OP4, D, L ) = SPEED END IF END IF 330 CONTINUE * * ------ Stop indentation ------ * 340 CONTINUE 350 CONTINUE 360 CONTINUE 370 CONTINUE 380 CONTINUE 390 CONTINUE * * ------ Continue indentation ------ * RETURN * * End of ZGBT01. * END SHAR_EOF fi # end of overwriting check if test -f 'zgbt02.f' then echo shar: will not over-write existing file "'zgbt02.f'" else cat << SHAR_EOF > 'zgbt02.f' SUBROUTINE ZGBT02( TABSUB, SIDE, NSIDE, NUPLO, TRNS, NTRNS, NDIAG, $ DIM1, DIM2, NDIM, LDA, NLDA, ALPHA, BETA, $ A, B, C, LD, NMAX, NERR, MXSUB, MXOPT, $ MXTRNS, MXDIM, MXLDA, RUNS, RES ) * .. Scalar Arguments .. INTEGER LD, NMAX, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS COMPLEX*16 ALPHA, BETA * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER SIDE( MXOPT ), TRNS( MXTRNS ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) COMPLEX*16 A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ) DOUBLE PRECISION RES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, MXDIM, $ MXLDA ) * * * Determine problem configurations for ZGEMM that, for timing purposes, * "correspond" to problem configurations for the remaining Level 3 BLAS * routines. Time ZGEMM for problems that correspond to the Level 3 BLAS * problems timed in ZGBT01. Return the performance of ZGEMM in Mflops. * * ZGBT02 calls a DOUBLE PRECISION function DSECND with no arguments, * which is assumed to return the user time for a process in seconds * from some fixed starting-time. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, J, M, N, K, ADDS, MULTS, NOPS, $ D, L, R, OP1, OP2, OP3, OP4 DOUBLE PRECISION TIME, SPEED, TM0, TM1, TM2, TM3, TM4, TM5, TM6, $ TM7, TM8, TM9, TM10, TM11, TM12, TM13 * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX, MIN * .. External Functions .. LOGICAL LSAME DOUBLE PRECISION DSECND EXTERNAL LSAME, DSECND * .. External Subroutines .. EXTERNAL ZGEMM * .. Parameters .. DOUBLE PRECISION ZERO, SCALE COMPLEX*16 ONE, Z11 PARAMETER ( ZERO = 0.0D+0, SCALE = 1.0D+6, $ ONE = ( 1.0D+0, 0.0D+0 ), $ Z11 = ( 1.0D+0, 1.0D+0 ) ) * .. * .. Executable Statements .. TM0 = DSECND( ) TM0 = DSECND( ) TM0 = DSECND( ) TM1 = DSECND( ) * * ------ Stop indentation ------ * DO 240, L = 1, NLDA DO 230, OP1 = 1, NSIDE DO 220, OP3 = 1, NTRNS DO 210, D = 1, NDIM * * ------ Continue indentation ------ * RES( 1, OP1, 1, OP3, 1, D, L ) = ZERO RES( 2, OP1, 1, OP3, 1, D, L ) = ZERO RES( 3, OP1, 1, OP3, 1, D, L ) = ZERO RES( 4, OP1, 1, OP3, 1, D, L ) = ZERO RES( 5, OP1, 1, OP3, 1, D, L ) = ZERO DO 200, R = 1, RUNS * * Time the user-supplied library. Re-initialize C between the * timings to avoid overflow and to flush the cache. * IF( ( TABSUB( 1 ).OR.TABSUB( 2 ) ).AND.OP3.EQ.1 )THEN DO 20, J = 1, NMAX DO 10, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 10 CONTINUE 20 CONTINUE * * Time ZGEMM for a problem that corresponds to the following * problem for ZSYMM or ZHEMM: * ZSYMM( SIDE( OP1 ), UPLO( OP2 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) * IF( LSAME( SIDE( OP1 ), 'L' ) )THEN * * Use K = M. * TM2 = DSECND( ) CALL ZGEMM( 'N', 'N', DIM1( D ), DIM2( D ), DIM1( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM3 = DSECND( ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN * * Use K = N. * TM2 = DSECND( ) CALL ZGEMM( 'N', 'N', DIM1( D ), DIM2( D ), DIM2( D ), $ ALPHA, B, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM3 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' STOP END IF END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 40, J = 1, NMAX DO 30, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 30 CONTINUE 40 CONTINUE * * Time ZGEMM for a problem that corresponds to the following * problem for ZSYRK: * ZSYRK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), BETA, C, LDA( L ) ) * Use M = N and B = A in the call to ZGEMM. * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM4 = DSECND( ) CALL ZGEMM( 'N', 'T', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM5 = DSECND( ) ELSE IF( LSAME( TRNS( OP3 ), 'T' ) )THEN TM4 = DSECND( ) CALL ZGEMM( 'T', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM5 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 4 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 60, J = 1, NMAX DO 50, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 50 CONTINUE 60 CONTINUE * * Time ZGEMM for a problem that corresponds to the following * problem for ZHERK: * ZHERK( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * DBLE( ALPHA ), A, LDA( L ), DBLE( BETA ), C, LDA( L ) ) * Use M = N and B = A in the call to ZGEMM. * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM6 = DSECND( ) CALL ZGEMM( 'N', 'C', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM7 = DSECND( ) ELSE IF( LSAME( TRNS( OP3 ), 'C' ) )THEN TM6 = DSECND( ) CALL ZGEMM( 'C', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), A, LDA( L ), BETA, C, LDA( L ) ) TM7 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 5 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN DO 80, J = 1, NMAX DO 70, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 70 CONTINUE 80 CONTINUE * * Time ZGEMM for a problem that corresponds to the following * problem for ZSYR2K: * ZSYR2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM8 = DSECND( ) CALL ZGEMM( 'N', 'T', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM9 = DSECND( ) ELSE IF( LSAME( TRNS( OP3 ), 'T' ) )THEN TM8 = DSECND( ) CALL ZGEMM( 'T', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM9 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 6 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN DO 100, J = 1, NMAX DO 90, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 90 CONTINUE 100 CONTINUE * * Time ZGEMM for a problem that corresponds to the following * problem for ZHER2K: * ZHER2K( UPLO( OP2 ), TRNS( OP3 ), DIM1( D ), DIM2( D ), * ALPHA, A, LDA( L ), B, LDA( L ), * DBLE( BETA ), C, LDA( L ) ) * IF( LSAME( TRNS( OP3 ), 'N' ) )THEN TM10 = DSECND( ) CALL ZGEMM( 'N', 'C', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM11 = DSECND( ) ELSE IF( LSAME( TRNS( OP3 ), 'C' ) )THEN TM10 = DSECND( ) CALL ZGEMM( 'C', 'N', DIM1( D ), DIM1( D ), DIM2( D ), $ ALPHA, A, LDA( L ), B, LDA( L ), BETA, C, LDA( L ) ) TM11 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for TRANS: ', TRNS( OP3 ), '.' STOP END IF END IF IF( TABSUB( 7 ).OR.TABSUB( 8 ) )THEN DO 120, J = 1, NMAX DO 110, I = 1, LD C( I, J ) = Z11 + DCMPLX( 0.01D+0* $ DBLE( I+( J-1 )*NMAX )/ DBLE( NMAX*NMAX+1 ), $ 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 110 CONTINUE 120 CONTINUE * * Time ZGEMM for a problem that corresponds to the following * problems for ZTRMM and ZTRSM: * ZTRMM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), * DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, * A, LDA( L ), C, LDA( L ) ) * ZTRSM( SIDE( OP1 ), UPLO( OP2 ), TRNS( OP3 ), * DIAG( OP4 ), DIM1( D ), DIM2( D ), ALPHA, * A, LDA( L ), C, LDA( L ) ) * IF( LSAME( SIDE( OP1 ), 'L' ) )THEN * * C := alpha*A*C + C or C := alpha*A'*C + C. Use K = M. * TM12 = DSECND( ) CALL ZGEMM( TRNS( OP3 ), 'N', DIM1( D ), DIM2( D ), $ DIM1( D ), ALPHA, A, LDA( L ), B, LDA( L ), $ ONE, C, LDA( L ) ) TM13 = DSECND( ) ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN * * C := alpha*C*A + C or C := alpha*C*A' + C. Use K = N. * TM12 = DSECND( ) CALL ZGEMM( 'N', TRNS( OP3 ), DIM1( D ), DIM2( D ), $ DIM2( D ), ALPHA, B, LDA( L ), A, LDA( L ), $ ONE, C, LDA( L ) ) TM13 = DSECND( ) ELSE WRITE( NERR, FMT = * ) $ 'Error: Unknown value for SIDE: ', SIDE( OP1 ), '.' STOP END IF END IF * * Compute the performance of ZGEMM in Mflops for problem * configurations that corresponds to ZSYMM or ZHEMM. * IF( ( TABSUB( 1 ).OR.TABSUB( 2 ) ).AND.OP3.EQ.1 )THEN TIME = ( TM3 - TM2 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN MULTS = ( M + 1 )*M*N + MIN( M*N, M*M ) ADDS = M*M*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN MULTS = ( N + 1 )*M*N + MIN( M*N, N*N ) ADDS = M*N*N NOPS = 6*MULTS + 2*ADDS END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 1, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 130, OP2 = 1, NUPLO RES( 1, OP1, OP2, OP3, 1, D, L ) = SPEED RES( 2, OP1, OP2, OP3, 1, D, L ) = SPEED 130 CONTINUE END IF END IF * * Compute the performance of ZGEMM in Mflops for problem * configurations that corresponds to ZSYRK. * IF( TABSUB( 3 ).AND.OP1.EQ.1 )THEN TIME = ( TM5 - TM4 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( K + 1 )*N*N + MIN( N*K, N*N ) ADDS = K*N*N NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 3, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 140, OP2 = 1, NUPLO RES( 3, OP1, OP2, OP3, 1, D, L ) = SPEED 140 CONTINUE END IF END IF * * Compute the performance of ZGEMM in Mflops for problem * configurations that corresponds to ZHERK. * IF( TABSUB( 4 ).AND.OP1.EQ.1 )THEN TIME = ( TM7 - TM6 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) MULTS = ( K + 1 )*N*N + MIN( N*K, N*N ) ADDS = K*N*N NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 4, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 150, OP2 = 1, NUPLO RES( 4, OP1, OP2, OP3, 1, D, L ) = SPEED 150 CONTINUE END IF END IF * * Compute the performance of ZGEMM in Mflops for problem * configurations that corresponds to ZSYR2K. * IF( TABSUB( 5 ).AND.OP1.EQ.1 )THEN TIME = ( TM9 - TM8 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( K + 1 )*N*N + MIN( N*K, N*N ) NOPS = K*N*N NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 5, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 160, OP2 = 1, NUPLO RES( 5, OP1, OP2, OP3, 1, D, L ) = SPEED 160 CONTINUE END IF END IF * * Compute the performance of ZGEMM in Mflops for problem * configurations that corresponds to ZHER2K. * IF( TABSUB( 6 ).AND.OP1.EQ.1 )THEN TIME = ( TM11 - TM10 ) - ( TM1 - TM0 ) N = DIM1( D ) K = DIM2( D ) NOPS = ( K + 1 )*N*N + MIN( N*K, N*N ) NOPS = K*N*N NOPS = 6*MULTS + 2*ADDS IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 6, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 170, OP2 = 1, NUPLO RES( 6, OP1, OP2, OP3, 1, D, L ) = SPEED 170 CONTINUE END IF END IF * * Compute the performance of ZGEMM in Mflops for problem * configurations that corresponds to ZTRMM and ZTRSM. * IF( TABSUB( 7 ).OR.TABSUB( 8 ) )THEN TIME = ( TM13 - TM12 ) - ( TM1 - TM0 ) M = DIM1( D ) N = DIM2( D ) IF( LSAME( SIDE( OP1 ), 'L' ) )THEN MULTS = M*M*N + MIN( M*N, M*M ) ADDS = ( M - 1 )*M*N NOPS = 6*MULTS + 2*ADDS ELSE IF( LSAME( SIDE( OP1 ), 'R' ) )THEN MULTS = M*N*N + MIN( M*N, N*N ) ADDS = ( N - 1 )*M*N NOPS = 6*MULTS + 2*ADDS END IF IF( TIME.LE.ZERO )THEN SPEED = ZERO ELSE SPEED = DBLE( NOPS )/( TIME*SCALE ) END IF IF( RES( 7, OP1, 1, OP3, 1, D, L ).LT.SPEED )THEN DO 190, OP2 = 1, NUPLO DO 180, OP4 = 1, NDIAG RES( 7, OP1, OP2, OP3, OP4, D, L ) = SPEED RES( 8, OP1, OP2, OP3, OP4, D, L ) = SPEED 180 CONTINUE 190 CONTINUE END IF END IF 200 CONTINUE * * ------ Stop indentation ------ * 210 CONTINUE 220 CONTINUE 230 CONTINUE 240 CONTINUE * * ------ Continue indentation ------ * RETURN * * End of DGBT02. * END SHAR_EOF fi # end of overwriting check if test -f 'zgbtim.f' then echo shar: will not over-write existing file "'zgbtim.f'" else cat << SHAR_EOF > 'zgbtim.f' * * GEMM-Based Level 3 BLAS Benchmark * Double Complex * * The GEMM-Based Level 3 BLAS Benchmark is a tool for performance * evaluation of Level 3 BLAS kernel programs. With the announcement of * LAPACK, the need for high performance Level 3 BLAS kernels became * apparent. LAPACK is based on calls to the Level 3 BLAS kernels. This * benchmark measures and compares performance of a set of user supplied * Level 3 BLAS implementations and of the GEMM-Based Level 3 BLAS * implementations permanently included in the benchmark. The purpose of * the benchmark is to facilitate the user in determining the quality of * different Level 3 BLAS implementations. The included GEMM-Based * Level 3 BLAS routines provide a lower limit on the performance to be * expected from a highly optimized Level 3 BLAS library. * * All routines are written in Fortran 77 for portability. No changes to * the code should be necessary in order to run the programs correctly * on different target machines. In fact, we strongly recommend the user * to avoided changes, except to the user specified parameters and to * UNIT numbers for input and output communication. This will ensure * that performance results from different target machines are * comparable. * * The program calls a DOUBLE PRECISION function DSECND with no * arguments, which is assumed to return the user time for a process in * seconds from some fixed starting-time. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * PROGRAM ZGBTIM * .. Parameters .. INTEGER NIN, NOUT, NERR, IERR PARAMETER ( NIN = 5, NOUT = 6, NERR = 6 ) INTEGER LD, NMAX PARAMETER ( LD = 530, NMAX = LD ) INTEGER LLN, LST, LNM PARAMETER ( LLN = 256, LST = 50, LNM = 6 ) INTEGER MXTAB, MXOPT, MXTRNS, MXDIM, MXLDA, MXSUB, $ MXRUNS PARAMETER ( MXTAB = 6, MXSUB = 8, MXOPT = 2, MXTRNS = 3, $ MXDIM = 36, MXLDA = 24, MXRUNS = 20 ) COMPLEX*16 Z11, ALPHA, BETA PARAMETER ( Z11 = ( 1.0D+0, 1.0D+0 ), $ ALPHA = ( 0.9D+0, 0.05D+0 ), $ BETA = ( 1.1D+0, 0.03D+0 ) ) * .. Local Scalars .. INTEGER I, IB, IE, IX, J, JB, JE, KB, KE, $ NTAB, NSIDE, NUPLO, NTRNS, NDIAG, NDIM1, NDIM2, $ NLDA, NRUNS, RUNS, MATCH LOGICAL ERR1, ERR2, ERR3, ERR4, SUB * .. Intrinsic Functions .. INTRINSIC DBLE, DCMPLX * .. External Functions .. INTEGER EOLN LOGICAL LSAME, GETWRD EXTERNAL LSAME, GETWRD, EOLN * .. External Subroutines .. EXTERNAL ZGBT01, ZGBT02, ZGBTP1, ZGBTP2 * .. Local Arrays .. INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) LOGICAL SUBCHK( MXSUB ), TABSUB( MXSUB ), TAB( MXTAB ) COMPLEX*16 A( LD, NMAX ), B( LD, NMAX ), C( LD, NMAX ) DOUBLE PRECISION USRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ GBRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ) COMMON / ZBKCMN / A, B, C, USRES, GBRES, MMRES CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXTRNS ), $ DIAG( MXOPT ) CHARACTER INLN*( LLN ), INSTR*( LST ), BLANK*( LST ), $ LBL*( LST ), NAME( MXSUB )*( LNM ) CHARACTER INLNA( LLN ) EQUIVALENCE ( INLN, INLNA ) * .. Data statements .. DATA NTAB/ 0 /, NRUNS/ 0 /, NSIDE/ 0 /, NUPLO/ 0 /, $ NTRNS/ 0 /, NDIAG/ 0 /, NDIM1/ 0 /, NDIM2/ 0 /, $ NLDA/ 0 / DATA TAB/ MXTAB*.FALSE. /, TABSUB/ MXSUB*.FALSE. /, $ SUBCHK/ MXSUB*.FALSE. /, $ SIDE/ MXOPT*' ' /, UPLO/ MXOPT*' '/, $ TRNS/ MXTRNS*' ' /, DIAG/ MXOPT*' '/, $ NAME/ 'ZSYMM ', 'ZHEMM ', 'ZSYRK ', 'ZHERK ', $ 'ZSYR2K', 'ZHER2K', 'ZTRMM ', 'ZTRSM '/, $ SUB/ .FALSE. / DATA BLANK/' '/, $ LBL /' '/ * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. Store the line in the variable INLN. The first word (token) * of the line is stored in INLN( IB:IE ). * 10 READ( NIN, FMT = 9000, END = 210 ) INLN IF( .NOT.GETWRD( INLN, LLN, IB, IE ).OR. $ ( INLN( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * If INLN( IB:IE ) contains the key word for a parameter, then read * and store the parameter values given on the same line of the input * file, after the key word. * JB = IB JE = IE I = 0 ERR1 = .FALSE. ERR2 = .FALSE. ERR3 = .FALSE. ERR4 = .FALSE. * * Read the parameters from the line INLN. * IF( INLN( JB:JE ).EQ.'LBL' )THEN * * Read the label of this test. * IF( LBL.NE.BLANK )THEN ERR3 = .TRUE. END IF IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN KE = EOLN( INLN( JE+1:LLN ), LLN-JE ) JB = JE + KB JE = JE + KE IF( JE-JB+1.GT.LST )THEN ERR4 = .TRUE. ELSE LBL = INLN( JB:JE ) END IF END IF I = 1 ELSE IF( INLN( JB:JE ).EQ.'TAB' )THEN * * Read which tests to be made. * IF( NTAB.NE.0 )THEN ERR3 = .TRUE. END IF 20 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXTAB )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) IX IF( IERR.GT.0.OR.IX.LT.1.OR.IX.GT.MXTAB )THEN ERR1 = .TRUE. END IF IF( TAB( IX ) )THEN ERR1 = .TRUE. END IF TAB( IX ) = .TRUE. ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 20 END IF END IF NTAB = I ELSE IF( INLN( JB:JE ).EQ.'RUNS' )THEN * * Read the number of times each problem is to be executed. The * final performance results are computed using the best timing * result for each problem. * IF( NRUNS.NE.0 )THEN ERR3 = .TRUE. END IF 30 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.1 )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) RUNS IF( IERR.GT.0.OR.RUNS.LT.1.OR.RUNS.GT.MXRUNS )THEN ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 30 END IF END IF NRUNS = I ELSE IF( INLN( IB:IE ).EQ.'SIDE' )THEN * * Read the values for SIDE. * IF( NSIDE.NE.0 )THEN ERR3 = .TRUE. END IF 40 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'L' ) )THEN DO 50, J = 1, I IF( LSAME( SIDE( J ), 'L' ) ) ERR1 = .TRUE. 50 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'R' ) )THEN DO 60, J = 1, I IF( LSAME( SIDE( J ), 'R' ) ) ERR1 = .TRUE. 60 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 SIDE( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 40 END IF END IF NSIDE = I ELSE IF( INLN( IB:IE ).EQ.'UPLO' )THEN * * Read the values for UPLO. * IF( NUPLO.NE.0 )THEN ERR3 = .TRUE. END IF 70 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'U' ) )THEN DO 80, J = 1, I IF( LSAME( UPLO( J ), 'U' ) ) ERR1 = .TRUE. 80 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'L' ) )THEN DO 90, J = 1, I IF( LSAME( UPLO( J ), 'L' ) ) ERR1 = .TRUE. 90 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 UPLO( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 70 END IF END IF NUPLO = I ELSE IF( INLN( IB:IE ).EQ.'TRANS' )THEN * * Read the values for TRANS. * IF( NTRNS.NE.0 )THEN ERR3 = .TRUE. END IF 100 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXTRNS )THEN IF( LSAME( INLN( JB:JB ), 'N' ) )THEN DO 110, J = 1, I IF( LSAME( TRNS( J ), 'N' ) ) ERR1 = .TRUE. 110 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'T' ) )THEN DO 120, J = 1, I IF( LSAME( TRNS( J ), 'T' ) ) ERR1 = .TRUE. 120 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'C' ) )THEN DO 130, J = 1, I IF( LSAME( TRNS( J ), 'C' ) ) ERR1 = .TRUE. 130 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 TRNS( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 100 END IF END IF NTRNS = I ELSE IF( INLN( IB:IE ).EQ.'DIAG' )THEN * * Read the values for DIAG. * IF( NDIAG.NE.0 )THEN ERR3 = .TRUE. END IF 140 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE IF( I.LT.MXOPT )THEN IF( LSAME( INLN( JB:JB ), 'N' ) )THEN DO 150, J = 1, I IF( LSAME( DIAG( J ), 'N' ) ) ERR1 = .TRUE. 150 CONTINUE ELSE IF( LSAME( INLN( JB:JB ), 'U' ) )THEN DO 160, J = 1, I IF( LSAME( DIAG( J ), 'U' ) ) ERR1 = .TRUE. 160 CONTINUE ELSE ERR1 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.ERR1 )THEN I = I + 1 DIAG( I ) = INLN( JB:JB ) END IF IF( .NOT.ERR1.AND.JE.LT.LLN )THEN GO TO 140 END IF END IF NDIAG = I ELSE IF( INLN( IB:IE ).EQ.'DIM1' )THEN * * Read the values for the first matrix dimension (DIM1). * IF( NDIM1.NE.0 )THEN ERR3 = .TRUE. END IF 170 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXDIM )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) DIM1( I ) IF( IERR.GT.0.OR.DIM1( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( DIM1( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 170 END IF END IF NDIM1 = I ELSE IF( INLN( IB:IE ).EQ.'DIM2' )THEN * * Read the values for the second matrix dimension (DIM2). * IF( NDIM2.NE.0 )THEN ERR3 = .TRUE. END IF 180 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXDIM )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) DIM2( I ) IF( IERR.GT.0.OR.DIM2( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( DIM2( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 180 END IF END IF NDIM2 = I ELSE IF( INLN( IB:IE ).EQ.'LDA' )THEN * * Read the values for leading dimension (LDA). * IF( NLDA.NE.0 )THEN ERR3 = .TRUE. END IF 190 IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE I = I + 1 IF( I.LE.MXLDA )THEN INSTR = BLANK( 1:LST-JE+JB-1 )//INLN( JB:JE ) READ( INSTR, FMT = 9020, IOSTAT = IERR ) LDA( I ) IF( IERR.GT.0.OR.LDA( I ).LT.0 )THEN ERR1 = .TRUE. END IF IF( LDA( I ).GT.NMAX )THEN ERR2 = .TRUE. END IF ELSE ERR1 = .TRUE. END IF IF( .NOT.( ERR1.OR.ERR2 ).AND.JE.LT.LLN )THEN GO TO 190 END IF END IF NLDA = I ELSE IF( INLN( IB:IE ).EQ.'ZSYMM'.OR.INLN( IB:IE ).EQ.'ZHEMM'.OR. $ INLN( IB:IE ).EQ.'ZSYRK'.OR.INLN( IB:IE ).EQ.'ZHERK'.OR. $ INLN( IB:IE ).EQ.'ZSYR2K'.OR.INLN( IB:IE ).EQ.'ZHER2K'.OR. $ INLN( IB:IE ).EQ.'ZTRMM'.OR.INLN( IB:IE ).EQ.'ZTRSM' )THEN * * Read which routines to time. * MATCH = 0 DO 200, I = 1, MXSUB IF( NAME( I ).EQ.INLN( IB:IB+5 ) )THEN MATCH = I IF( SUBCHK( MATCH ) )THEN ERR3 = .TRUE. END IF SUBCHK( MATCH ) = .TRUE. END IF 200 CONTINUE IF( GETWRD( INLN( JE+1:LLN ), LLN-JE, KB, KE ) )THEN JB = JE + KB JE = JE + KE * * Time the routine if the first non-blank character * INLN( JB:JB ) is 'T' or 't'. * TABSUB( MATCH ) = LSAME( INLN( JB:JB ), 'T' ) IF( .NOT.( TABSUB( MATCH ).OR. $ LSAME( INLN( JB:JB ), 'F' ) ) )THEN ERR1 = .TRUE. END IF SUB = SUB.OR.TABSUB( MATCH ) I = 1 ELSE I = 0 END IF ELSE WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: Unknown parameter ', INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP END IF * IF( I.EQ.0 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: No values or erroneous values given ', $ 'for the parameter ', INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR1 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Erroneus value or too many values for the parameter ', $ INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR2 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Value too large for ', INLN( IB:IE ), '. Max ', NMAX, '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR3 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Multiple specifications of the input parameter ', $ INLN( IB:IE ), '.' WRITE( NERR, FMT = * ) STOP ELSE IF( ERR4 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = 9010 ) $ 'The label of this test is too long. Max ', LST, $ ' characters.' WRITE( NERR, FMT = * ) STOP END IF GO TO 10 * 210 CONTINUE IF( NTAB.LE.0 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: No results are chosen to be presented' WRITE( NERR, FMT = * ) $ ' (see the parameter TAB).' WRITE( NERR, FMT = * ) STOP END IF IF( ( TAB( 2 ).OR.TAB( 3 ).OR.TAB( 4 ).OR.TAB( 5 ).OR.TAB( 6 ) ) $ .AND.( NRUNS.LE.0.OR.NSIDE.LE.0.OR.NUPLO.LE.0.OR. $ NTRNS.LE.0.OR.NDIAG.LE.0.OR.NDIM1.LE.0.OR. $ NDIM2.LE.0.OR.NLDA.LE.0.OR.( .NOT.SUB ) ) )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: A parameter, or values for a parameter, is missing.' WRITE( NERR, FMT = * ) $ 'One (or more) of the input parameters RUNS, SIDE, UPLO,' WRITE( NERR, FMT = * ) $ 'TRANS, DIAG, DIM1, DIM2, LDA are missing, or none of the' WRITE( NERR, FMT = * ) $ 'routines ZSYMM, ZHEMM, ZSYRK, ZHERK, ZSYR2K, ZHER2K,' WRITE( NERR, FMT = * ) $ 'ZTRMM, and ZTRSM are marked to be timed', '.' WRITE( NERR, FMT = * ) STOP END IF IF( NDIM1.NE.NDIM2 )THEN WRITE( NERR, FMT = * ) WRITE( NERR, FMT = * ) $ 'Error: Different number of dimensions ', $ 'for DIM1 and DIM2', '.' WRITE( NERR, FMT = * ) STOP END IF * * Initialize the matrices A and B. * DO 230, J = 1, NMAX DO 220, I = 1, NMAX A( I, J ) = Z11 + DCMPLX( 0.08D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ), 0.06D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 220 CONTINUE 230 CONTINUE DO 250, J = 1, NMAX DO 240, I = 1, NMAX B( I, J ) = Z11 + DCMPLX( 0.04D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ), 0.02D+0*DBLE( I+( J-1 )*NMAX )/ $ DBLE( NMAX*NMAX+1 ) ) 240 CONTINUE 250 CONTINUE * * Time the routines and calculate the results. * IF( TAB( 2 ).OR.TAB( 6 ) )THEN * * Time the internal GEMM-Based Level 3 BLAS routines (ZGB02, * ZGB03, ZGB04, ZGB05, ZGB06, ZGB07, ZGB08, and ZGB09). * CALL ZGBT01( 'G', TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXTRNS, MXDIM, MXLDA, RUNS, GBRES ) END IF IF( TAB( 1 ).OR.TAB( 3 ).OR.TAB( 5 ).OR.TAB( 6 ) )THEN * * Time the user-supplied Level 3 BLAS library. * CALL ZGBT01( 'U', TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ ALPHA, BETA, A, B, C, LD, NMAX, NERR, MXSUB, $ MXOPT, MXTRNS, MXDIM, MXLDA, RUNS, USRES ) END IF IF( TAB( 1 ).OR.TAB( 4 ).OR.TAB( 5 ) )THEN * * Time ZGEMM using user specified parameters. * CALL ZGBT02( TABSUB, SIDE, NSIDE, NUPLO, TRNS, NTRNS, NDIAG, $ DIM1, DIM2, NDIM1, LDA, NLDA, ALPHA, BETA, $ A, B, C, LD, NMAX, NERR, MXSUB, MXOPT, $ MXTRNS, MXDIM, MXLDA, RUNS, MMRES ) END IF IF( TAB( 1 ) )THEN * * Calculate and print the collected benchmark result. * CALL ZGBTP1( TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, NTRNS, $ DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, NOUT, $ NERR, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS, $ ALPHA, BETA, LBL, USRES, MMRES ) END IF IF( TAB( 2 ).OR.TAB( 3 ).OR.TAB( 4 ).OR.TAB( 5 ).OR.TAB( 6 ) )THEN * * Calculate and print the results of TAB choice 2 - 6. * CALL ZGBTP2( TAB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM1, LDA, NLDA, $ NOUT, MXTAB, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, $ RUNS, ALPHA, BETA, LBL, USRES, MMRES, GBRES ) END IF * STOP * 9000 FORMAT( A ) 9010 FORMAT( 1X, A, I3, A ) 9020 FORMAT( I50 ) * * End of ZGBTIM. * END SHAR_EOF fi # end of overwriting check if test -f 'zgbtp1.f' then echo shar: will not over-write existing file "'zgbtp1.f'" else cat << SHAR_EOF > 'zgbtp1.f' SUBROUTINE ZGBTP1( TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, NTRNS, $ DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, NOUT, $ NERR, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, $ RUNS, ALPHA, BETA, LBL, USRES, MMRES ) * .. Scalar Arguments .. INTEGER NOUT, NERR, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS COMPLEX*16 ALPHA, BETA * .. Parameters .. INTEGER LST PARAMETER ( LST = 50 ) * .. Array Arguments .. LOGICAL TABSUB( MXSUB ) CHARACTER LBL*( LST ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXTRNS ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) DOUBLE PRECISION USRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ) * * * ZGBTP1 prints the collected benchmark result which is calculated from * performance results of the user-supplied Level 3 routines for * problems specified in the input file. The result consists of a tuple * ( x, y ), where x is the mean value of the GEMM-Efficiency and y is * the mean value of the performance of ZGEMM in megaflops. ZGEMM is * timed for problems corresponding to those specified for the remaining * Level 3 routines. * * The purpose of the collected benchmark result is to provide an * overall performance measure of the user-supplied Level 3 BLAS * routines. The intention is to expose the capacity of the target * machine for these kinds of problems and to show how well the routines * utilize the machine. Furthermore, the collected result is intended to * be easy to compare between different target machines. See the README * and INSTALL files for further information. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, D, L, NTIM, OP1, OP2, OP3 DOUBLE PRECISION SPEED, EFF, MM, MMSUM, EFSUM * .. Intrinsic Functions .. INTRINSIC DBLE * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. Parameters .. DOUBLE PRECISION ZERO INTEGER MXBSUB PARAMETER ( ZERO = 0.0D+0, MXBSUB = 8 ) * .. * .. Executable Statements .. IF( MXSUB.GT.MXBSUB )THEN WRITE( NERR, FMT = 9000 ) STOP END IF * MMSUM = ZERO EFSUM = ZERO NTIM = 0 * * ------ Stop indentation ------ * DO 50, L = 1, NLDA DO 40, OP1 = 1, NSIDE DO 30, OP2 = 1, NUPLO DO 20, OP3 = 1, NTRNS DO 10, D = 1, NDIM * * ------ Continue indentation ------ * * * Compute the sum of the performance of ZGEMM in megaflops (MMSUM) * and the sum of the GEMM-Efficiency (EFSUM). * IF( TABSUB( 1 ).AND.OP3.EQ.1 )THEN MM = MMRES( 1, OP1, OP2, 1, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 1, OP1, OP2, 1, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 2 ).AND.OP3.EQ.1 )THEN MM = MMRES( 2, OP1, OP2, 1, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 2, OP1, OP2, 1, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 3 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN MM = MMRES( 3, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 3, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 4 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN MM = MMRES( 4, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 4, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 5 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN MM = MMRES( 5, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 5, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 6 ).AND.OP1.EQ.1.AND. $ .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN MM = MMRES( 6, 1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 6, 1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 7 ) )THEN MM = MMRES( 7, OP1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 7, OP1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF IF( TABSUB( 8 ) )THEN MM = MMRES( 8, OP1, OP2, OP3, 1, D, L ) MMSUM = MMSUM + MM IF( MM.GT.ZERO )THEN EFSUM = EFSUM + USRES( 8, OP1, OP2, OP3, 1, D, L )/MM ELSE WRITE( NERR, FMT = 9010 ) STOP END IF NTIM = NTIM + 1 END IF * * ------ Stop indentation ------ * 10 CONTINUE 20 CONTINUE 30 CONTINUE 40 CONTINUE 50 CONTINUE * * ------ Continue indentation ------ * * * Compute the collected benchmark result ( x, y ) as the mean value * of the GEMM-Efficiency ( x ) and the mean value of the performance * of ZGEMM in megaflops ( y ). * SPEED = MMSUM/DBLE( NTIM ) EFF = EFSUM/DBLE( NTIM ) * * Print an introduction and the collected benchmark result. * WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9020 ) WRITE( NOUT, FMT = 9030 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9040 ) RUNS WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9050 ) WRITE( NOUT, FMT = 9060 ) 'SIDE ', ( SIDE( I ), I = 1, NSIDE ) WRITE( NOUT, FMT = 9060 ) 'UPLO ', ( UPLO( I ), I = 1, NUPLO ) WRITE( NOUT, FMT = 9060 ) 'TRANS ', ( TRNS( I ), I = 1, NTRNS ) WRITE( NOUT, FMT = 9060 ) 'DIAG ', ( DIAG( I ), I = 1, NDIAG ) WRITE( NOUT, FMT = 9070 ) 'DIM1 ', ( DIM1( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9070 ) 'DIM2 ', ( DIM2( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9070 ) 'LDA ', ( LDA( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9080 ) 'ALPHA ', ALPHA WRITE( NOUT, FMT = 9080 ) 'BETA ', BETA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9090 ) LBL WRITE( NOUT, FMT = 9100 ) EFF, SPEED WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) * RETURN * * Print formats. * 9000 FORMAT( 1X, 'Error: The collected benchmark result could not ', $ 'be obtained.',/, $ 1X, 'The value for the input parameter MXSUB is too ', $ 'large.' ) 9010 FORMAT( 1X, 'Error: The collected benchmark result could not ', $ 'be obtained.',/, $ 1X, 'Execution time for ZGEMM is zero.' ) 9020 FORMAT( 17X, '**** GEMM-Based Level 3 BLAS Benchmark ****' ) 9030 FORMAT( 27X, 'Collected Benchmark Result',/, $ 33X, 'Double Complex' ) 9040 FORMAT( 2X, 'The collected benchmark result is a tuple ', $ '( x, y ) where x is the mean',/, $ 2X, 'value of the GEMM-Efficiency and y is the mean ', $ 'value of the performance',/, $ 2X, 'of ZGEMM in megaflops (see the README file). The ', $ 'benchmark result is',/, $ 2X, 'based on the shortest of', I3,' runs for each ', $ 'problem configuration.' ) 9050 FORMAT( 8X, 'Input parameters.' ) 9060 FORMAT( 8X, A, ' ', 10( A, ' ' ) ) 9070 FORMAT( 8X, A, 1X, 12( I5 ), 2( /, 16X, 12( I5 ) ) ) 9080 FORMAT( 8X, A, ( '(', F6.2, ',', F6.2, ')' ) ) 9090 FORMAT( 8X, 'Test label: ', A ) 9100 FORMAT( 8X, 'Collected result: (', F7.2,',', F9.1,' )' ) 9110 FORMAT( 1X, '**************************************************', $ '****************************' ) * * End of ZGBTP1. * END SHAR_EOF fi # end of overwriting check if test -f 'zgbtp2.f' then echo shar: will not over-write existing file "'zgbtp2.f'" else cat << SHAR_EOF > 'zgbtp2.f' SUBROUTINE ZGBTP2( TAB, TABSUB, SIDE, NSIDE, UPLO, NUPLO, TRNS, $ NTRNS, DIAG, NDIAG, DIM1, DIM2, NDIM, LDA, NLDA, $ NOUT, MXTAB, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, $ RUNS, ALPHA, BETA, LBL, USRES, MMRES, GBRES ) * .. Scalar Arguments .. INTEGER NOUT, $ NSIDE, NUPLO, NTRNS, NDIAG, NDIM, NLDA, $ MXTAB, MXSUB, MXOPT, MXTRNS, MXDIM, MXLDA, RUNS COMPLEX*16 ALPHA, BETA * .. Parameters .. INTEGER LST PARAMETER ( LST = 50 ) * .. Array Arguments .. LOGICAL TABSUB( MXSUB ), TAB( MXTAB ) CHARACTER LBL*( LST ) CHARACTER SIDE( MXOPT ), UPLO( MXOPT ), TRNS( MXTRNS ), $ DIAG( MXOPT ) INTEGER DIM1( MXDIM ), DIM2( MXDIM ), LDA( MXLDA ) DOUBLE PRECISION USRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ GBRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ), $ MMRES( MXSUB, MXOPT, MXOPT, MXTRNS, MXOPT, $ MXDIM, MXLDA ) * * * ZGBTP2 prints tables showing detailed performance results and * comparisons between the user-supplied and the built-in GEMM-Based * Level 3 BLAS routines. The table results are intended for program * developers and others who are interested in detailed performance * presentations. Performance of the user-supplied and the built-in * GEMM-Based Level 3 BLAS routines are shown. The tables also show * GEMM-Efficiency and GEMM-Ratio. See the README and INSTALL files * for further information. * * * -- Written in August-1994. * GEMM-Based Level 3 BLAS Benchmark. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER D, I, L, NTIM, OP1, OP2, OP3, OP4 DOUBLE PRECISION MM, GE, GB, GR, US * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. Parameters .. INTEGER MXTOTS, LLN DOUBLE PRECISION ZERO, HUGE PARAMETER ( MXTOTS = 6, LLN = 256, ZERO = 0.0D+0, $ HUGE = 1.0D+10 ) INTEGER B1, B2, B3, B4, B5, B6, B7, B8, B9, B10, B11, $ E1, E2, E3, E4, E5, E6, E7, E8, E9, E10, E11 PARAMETER ( B1 = 1, B2 = 3, B3 = 5, B4 = 7, B5 = 9, $ B6 = 16, B7 = 23, B8 = 34, B9 = 45, B10 = 56, $ B11 = 66, $ E1 = 2, E2 = 4, E3 = 6, E4 = 8, E5 = 15, $ E6 = 22, E7 = 33, E8 = 44, E9 = 55, E10 = 65, $ E11 = 74 ) * .. Local Arrays .. CHARACTER OUTLN*( LLN ), OUTLN2*( LLN ), OUTLN3*( LLN ) DOUBLE PRECISION MI( MXTOTS ), MA( MXTOTS ), SU( MXTOTS ) * .. * .. Executable Statements .. * * Print an introduction. * WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9000 ) WRITE( NOUT, FMT = 9010 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9020 ) WRITE( NOUT, FMT = 9030 ) 'SIDE ', ( SIDE( I ), I = 1, NSIDE ) WRITE( NOUT, FMT = 9030 ) 'UPLO ', ( UPLO( I ), I = 1, NUPLO ) WRITE( NOUT, FMT = 9030 ) 'TRANS ', ( TRNS( I ), I = 1, NTRNS ) WRITE( NOUT, FMT = 9030 ) 'DIAG ', ( DIAG( I ), I = 1, NDIAG ) WRITE( NOUT, FMT = 9040 ) 'DIM1 ', ( DIM1( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9040 ) 'DIM2 ', ( DIM2( I ), I = 1, NDIM ) WRITE( NOUT, FMT = 9040 ) 'LDA ', ( LDA( I ), I = 1, NLDA ) WRITE( NOUT, FMT = 9050 ) 'ALPHA ', ALPHA WRITE( NOUT, FMT = 9050 ) 'BETA ', BETA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9060 ) RUNS WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9070 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9080 ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9090 ) LBL WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) * * Print result tables for ZSYMM. * IF( TABSUB( 1 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'ZSYMM ', $ ' OPTIONS = SIDE,UPLO' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 50, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 10, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 10 CONTINUE NTIM = 0 DO 40, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 30, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 20, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 1, OP1, OP2, 1, 1, D, L ) MM = MMRES( 1, OP1, OP2, 1, 1, D, L ) GB = GBRES( 1, OP1, OP2, 1, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B7:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 20 CONTINUE 30 CONTINUE 40 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 50 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for ZHEMM. * IF( TABSUB( 2 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'ZHEMM ', $ ' OPTIONS = SIDE,UPLO' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 100, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 60, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 60 CONTINUE NTIM = 0 DO 90, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 80, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 70, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 2, OP1, OP2, 1, 1, D, L ) MM = MMRES( 2, OP1, OP2, 1, 1, D, L ) GB = GBRES( 2, OP1, OP2, 1, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B7:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 70 CONTINUE 80 CONTINUE 90 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 100 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for ZSYRK. * IF( TABSUB( 3 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'ZSYRK ', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 150, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 110, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 110 CONTINUE NTIM = 0 DO 140, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 130, OP3 = 1, NTRNS IF( .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 120, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 3, 1, OP2, OP3, 1, D, L ) MM = MMRES( 3, 1, OP2, OP3, 1, D, L ) GB = GBRES( 3, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 120 CONTINUE END IF 130 CONTINUE 140 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 150 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for ZHERK. * IF( TABSUB( 4 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'ZHERK ', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 200, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 160, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 160 CONTINUE NTIM = 0 DO 190, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 180, OP3 = 1, NTRNS IF( .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 170, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 4, 1, OP2, OP3, 1, D, L ) MM = MMRES( 4, 1, OP2, OP3, 1, D, L ) GB = GBRES( 4, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 170 CONTINUE END IF 180 CONTINUE 190 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 200 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for ZSYR2K. * IF( TABSUB( 5 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'ZSYR2K', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 250, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 210, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 210 CONTINUE NTIM = 0 DO 240, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 230, OP3 = 1, NTRNS IF( .NOT.LSAME( TRNS( OP3 ), 'C' ) )THEN WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 220, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 5, 1, OP2, OP3, 1, D, L ) MM = MMRES( 5, 1, OP2, OP3, 1, D, L ) GB = GBRES( 5, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 220 CONTINUE END IF 230 CONTINUE 240 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 250 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for ZHER2K. * IF( TABSUB( 6 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'ZHER2K', $ ' OPTIONS = UPLO,TRANS' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'N', 'K' DO 300, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 260, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 260 CONTINUE NTIM = 0 DO 290, OP2 = 1, NUPLO WRITE( OUTLN( B1:E1 ), FMT = 9130 ) UPLO( OP2 ) DO 280, OP3 = 1, NTRNS IF( .NOT.LSAME( TRNS( OP3 ), 'T' ) )THEN WRITE( OUTLN( B2:E2 ), FMT = 9130 ) TRNS( OP3 ) WRITE( OUTLN( B3:E3 ), FMT = 9130 ) ' ' WRITE( OUTLN( B4:E4 ), FMT = 9130 ) ' ' DO 270, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 6, 1, OP2, OP3, 1, D, L ) MM = MMRES( 6, 1, OP2, OP3, 1, D, L ) GB = GBRES( 6, 1, OP2, OP3, 1, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 270 CONTINUE END IF 280 CONTINUE 290 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 300 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for ZTRMM. * IF( TABSUB( 7 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'ZTRMM ', $ 'OPTIONS = SIDE,UPLO,TRANS,DIAG' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 370, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 310, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 310 CONTINUE NTIM = 0 DO 360, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 350, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) DO 340, OP3 = 1, NTRNS WRITE( OUTLN( B3:E3 ), FMT = 9130 ) TRNS( OP3 ) DO 330, OP4 = 1, NDIAG WRITE( OUTLN( B4:E4 ), FMT = 9130 ) DIAG( OP4 ) DO 320, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 7, OP1, OP2, OP3, OP4, D, L ) MM = MMRES( 7, OP1, OP2, OP3, OP4, D, L ) GB = GBRES( 7, OP1, OP2, OP3, OP4, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 320 CONTINUE 330 CONTINUE 340 CONTINUE 350 CONTINUE 360 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 370 CONTINUE WRITE( NOUT, FMT = * ) END IF * * Print result tables for ZTRSM. * IF( TABSUB( 8 ) )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9100 ) 'ZTRSM ', $ 'OPTIONS = SIDE,UPLO,TRANS,DIAG' WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9110 ) 'M', 'N' DO 440, L = 1, NLDA WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9120 ) LDA( L ) DO 380, I = 1, MXTOTS MI( I ) = HUGE MA( I ) = ZERO SU( I ) = ZERO 380 CONTINUE NTIM = 0 DO 430, OP1 = 1, NSIDE WRITE( OUTLN( B1:E1 ), FMT = 9130 ) SIDE( OP1 ) DO 420, OP2 = 1, NUPLO WRITE( OUTLN( B2:E2 ), FMT = 9130 ) UPLO( OP2 ) DO 410, OP3 = 1, NTRNS WRITE( OUTLN( B3:E3 ), FMT = 9130 ) TRNS( OP3 ) DO 400, OP4 = 1, NDIAG WRITE( OUTLN( B4:E4 ), FMT = 9130 ) DIAG( OP4 ) DO 390, D = 1, NDIM WRITE( OUTLN( B5:E5 ), FMT = 9140 ) DIM1( D ) WRITE( OUTLN( B6:E6 ), FMT = 9140 ) DIM2( D ) US = USRES( 8, OP1, OP2, OP3, OP4, D, L ) MM = MMRES( 8, OP1, OP2, OP3, OP4, D, L ) GB = GBRES( 8, OP1, OP2, OP3, OP4, D, L ) NTIM = NTIM + 1 IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) GB IF( MI( 2 ).GT.GB ) MI( 2 ) = GB IF( MA( 2 ).LT.GB ) MA( 2 ) = GB SU( 2 ) = SU( 2 ) + GB ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) US IF( MI( 3 ).GT.US ) MI( 3 ) = US IF( MA( 3 ).LT.US ) MA( 3 ) = US SU( 3 ) = SU( 3 ) + US ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MM IF( MI( 4 ).GT.MM ) MI( 4 ) = MM IF( MA( 4 ).LT.MM ) MA( 4 ) = MM SU( 4 ) = SU( 4 ) + MM ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN IF( MM.GT.ZERO )THEN GE = US/MM ELSE GE = ZERO END IF WRITE( OUTLN( B10:E10 ), FMT = 9170 ) GE IF( MI( 5 ).GT.GE ) MI( 5 ) = GE IF( MA( 5 ).LT.GE ) MA( 5 ) = GE SU( 5 ) = SU( 5 ) + GE ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN IF( US.GT.ZERO )THEN GR = GB/US ELSE GR = ZERO END IF WRITE( OUTLN( B11:E11 ), FMT = 9190 ) GR IF( MI( 6 ).GT.GR ) MI( 6 ) = GR IF( MA( 6 ).LT.GR ) MA( 6 ) = GR SU( 6 ) = SU( 6 ) + GR ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) 390 CONTINUE 400 CONTINUE 410 CONTINUE 420 CONTINUE 430 CONTINUE WRITE( NOUT, FMT = 9220 ) * * Print the min, max, and mean values. * WRITE( OUTLN( B1:E6 ), FMT = 9230 ) WRITE( OUTLN2( B1:E6 ), FMT = 9240 ) WRITE( OUTLN3( B1:E6 ), FMT = 9250 ) IF( TAB( 2 ) )THEN WRITE( OUTLN( B7:E7 ), FMT = 9150 ) MI( 2 ) WRITE( OUTLN2( B7:E7 ), FMT = 9150 ) MA( 2 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B7:E7 ), FMT = 9150 ) SU( 2 )/NTIM END IF ELSE WRITE( OUTLN( B7:E7 ), FMT = 9160 ) WRITE( OUTLN2( B7:E7 ), FMT = 9160 ) WRITE( OUTLN3( B7:E7 ), FMT = 9160 ) END IF IF( TAB( 3 ) )THEN WRITE( OUTLN( B8:E8 ), FMT = 9150 ) MI( 3 ) WRITE( OUTLN2( B8:E8 ), FMT = 9150 ) MA( 3 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B8:E8 ), FMT = 9150 ) SU( 3 )/NTIM END IF ELSE WRITE( OUTLN( B8:E8 ), FMT = 9160 ) WRITE( OUTLN2( B8:E8 ), FMT = 9160 ) WRITE( OUTLN3( B8:E8 ), FMT = 9160 ) END IF IF( TAB( 4 ) )THEN WRITE( OUTLN( B9:E9 ), FMT = 9150 ) MI( 4 ) WRITE( OUTLN2( B9:E9 ), FMT = 9150 ) MA( 4 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B9:E9 ), FMT = 9150 ) SU( 4 )/NTIM END IF ELSE WRITE( OUTLN( B9:E9 ), FMT = 9160 ) WRITE( OUTLN2( B9:E9 ), FMT = 9160 ) WRITE( OUTLN3( B9:E9 ), FMT = 9160 ) END IF IF( TAB( 5 ) )THEN WRITE( OUTLN( B10:E10 ), FMT = 9170 ) MI( 5 ) WRITE( OUTLN2( B10:E10 ), FMT = 9170 ) MA( 5 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B10:E10 ), FMT = 9170 ) SU( 5 )/NTIM END IF ELSE WRITE( OUTLN( B10:E10 ), FMT = 9180 ) WRITE( OUTLN2( B10:E10 ), FMT = 9180 ) WRITE( OUTLN3( B10:E10 ), FMT = 9180 ) END IF IF( TAB( 6 ) )THEN WRITE( OUTLN( B11:E11 ), FMT = 9190 ) MI( 6 ) WRITE( OUTLN2( B11:E11 ), FMT = 9190 ) MA( 6 ) IF( NTIM.NE.0 )THEN WRITE( OUTLN3( B11:E11 ), FMT = 9190 ) SU( 6 )/NTIM END IF ELSE WRITE( OUTLN( B11:E11 ), FMT = 9200 ) WRITE( OUTLN2( B11:E11 ), FMT = 9200 ) WRITE( OUTLN3( B11:E11 ), FMT = 9200 ) END IF WRITE( NOUT, FMT = 9210 ) OUTLN( B1:E11 ) WRITE( NOUT, FMT = 9210 ) OUTLN2( B1:E11 ) IF( NTIM.NE.0 )THEN WRITE( NOUT, FMT = 9210 ) OUTLN3( B1:E11 ) END IF WRITE( NOUT, FMT = * ) 440 CONTINUE END IF WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9260 ) * RETURN * * Print formats. * 9000 FORMAT( 17X, '**** GEMM-Based Level 3 BLAS Benchmark ****' ) 9010 FORMAT( 33X, 'Table Results',/, $ 33X, 'Double Complex' ) 9020 FORMAT( 8X, 'Input parameters.' ) 9030 FORMAT( 8X, A, 3X, 10( A, ' ' ) ) 9040 FORMAT( 8X, A, 1X, 12( I5 ), 2( /, 16X, 12( I5 ) ) ) 9050 FORMAT( 8X, A, ( '(', F6.2, ',', F6.2, ')' ) ) 9060 FORMAT( 8X, 'Results are based on the shortest execution time ', $ 'of ', I2, ' runs for ',/, $ 8X, 'each problem configuration.' ) 9070 FORMAT( 27X, 'Performance of a user-supplied',/, $ 27X, 'Level 3 BLAS routine (megaflops).',/, $ 8X, 'GEMM-Efficiency = -------------------------------', $ '----',/, $ 27X, 'Performance of the user-supplied',/, $ 27X, 'ZGEMM routine (megaflops).' ) 9080 FORMAT( 22X, 'Performance for the internal GEMM-Based',/, $ 22X, 'Level 3 BLAS routine Zxxxx (megaflops).',/, $ 8X, 'GEMM-Ratio = ------------------------------------', $ '-----',/, $ 22X, 'Performance of the user-supplied',/, $ 22X, 'Level 3 BLAS routine Zxxxx (megaflops).' ) 9090 FORMAT( 8X, 'Test label: ', A ) 9100 FORMAT( 2X, A, 38X, A ) 9110 FORMAT( 31X, 'GEMM- User-', /, $ 29X,'Based lib suppl lib ZGEMM GEMM- GEMM-', /, $ 2X, 'OPTIONS ', A,' ', A,' ', $ 'Mflops Mflops Mflops Eff. Ratio', /, $ 2X, '==================================================', $ '=========================' ) 9120 FORMAT( 2X, '( LDA = ', I4, ' )' ) 9130 FORMAT( A ) 9140 FORMAT( I7 ) 9150 FORMAT( F11.1 ) 9160 FORMAT( ' ' ) 9170 FORMAT( F10.2 ) 9180 FORMAT( ' ' ) 9190 FORMAT( F9.2 ) 9200 FORMAT( ' ' ) 9210 FORMAT( 2X, A ) 9220 FORMAT( 2X, '--------------------------------------------------', $ '-------------------------' ) 9230 FORMAT( 'Min ', 15X ) 9240 FORMAT( 'Max ', 15X ) 9250 FORMAT( 'Mean ', 15X ) 9260 FORMAT( 1X, '**************************************************', $ '****************************' ) * * End of ZGBTP2. * END SHAR_EOF fi # end of overwriting check if test -f 'zmark01.in' then echo shar: will not over-write existing file "'zmark01.in'" else cat << SHAR_EOF > 'zmark01.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * ZMARK01 * * * We propose two standard test suits for the collected benchmark * result, ZMARK01 and ZMARK02 (see the files 'zmark01.in' and * 'zmark02.in'). These tests are designed to show performance of the * user-supplied Level 3 library for problem sizes that are likely to * often be requested by a calling routine. This imply problems that * presumably constitute a large part of computations in routines which * use the Level 3 BLAS as their major computational kernels. LAPACK * implements blocked algorithms which are based on calls to the Level 3 * BLAS. The problems in the two tests are similar. However, some of the * matrix dimensions are larger in ZMARK02 than in ZMARK01. This * corresponds to larger matrix blocks in the calling routine. The tests * are expected to match various target machines differently. * Performance results may depend strongly on sizes of different storage * units in the memory hierarchy. The size of the cache memory, for * instance, may be decisive. For this reason, we propose two standard * tests instead of one. * * *** Label of this test *** LBL ZMARK01 *** Benchmark results to be presented *** TAB 1 3 4 5 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 3 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T C DIAG N U DIM1 16 32 512 512 512 DIM2 512 512 16 32 512 LDA 512 530 *** Routines to be timed *** ZSYMM T ZHEMM T ZSYRK T ZHERK T ZSYR2K T ZHER2K T ZTRMM T ZTRSM T SHAR_EOF fi # end of overwriting check if test -f 'zmark02.in' then echo shar: will not over-write existing file "'zmark02.in'" else cat << SHAR_EOF > 'zmark02.in' * * **** GEMM-Based Level 3 BLAS Benchmark **** * ZMARK02 * * * We propose two standard test suits for the collected benchmark * result, ZMARK01 and ZMARK02 (see the files 'zmark01.in' and * 'zmark02.in'). These tests are designed to show performance of the * user-supplied Level 3 library for problem sizes that are likely to * often be requested by a calling routine. This imply problems that * presumably constitute a large part of computations in routines which * use the Level 3 BLAS as their major computational kernels. LAPACK * implements blocked algorithms which are based on calls to the Level 3 * BLAS. The problems in the two tests are similar. However, some of the * matrix dimensions are larger in ZMARK02 than in ZMARK01. This * corresponds to larger matrix blocks in the calling routine. The tests * are expected to match various target machines differently. * Performance results may depend strongly on sizes of different storage * units in the memory hierarchy. The size of the cache memory, for * instance, may be decisive. For this reason, we propose two standard * tests instead of one. * * *** Label of this test *** LBL ZMARK02 *** Benchmark results to be presented *** TAB 1 3 4 5 *** Results presented are based on the fastest of *** *** RUNS executions of each problem configuration *** RUNS 3 *** Values of input parameters for the Level 3 BLAS routines *** SIDE L R UPLO U L TRANS N T C DIAG N U DIM1 64 128 512 512 512 DIM2 512 512 64 128 512 LDA 512 530 *** Routines to be timed *** ZSYMM T ZHEMM T ZSYRK T ZHERK T ZSYR2K T ZHER2K T ZTRMM T ZTRSM T SHAR_EOF fi # end of overwriting check if test -f 'zsbpm.f' then echo shar: will not over-write existing file "'zsbpm.f'" else cat << SHAR_EOF > 'zsbpm.f' PROGRAM ZSBPM * * ZSBPM re-writes GEMM-Based Level 3 BLAS source files replacing lines * containing old PARAMETER statements for user specified parameters, * with lines containing new PARAMETER statements given in an input * file. The user can conveniently assign new values to the PARAMETER * statements in the input file, and then run ZSBPM to distribute these * values to the GEMM-based routines. An input file consists of three * different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file (see the input file * 'dgpm.in'). Read the file INSTALL for further instructions. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, IB, IE, JB, JE, KB, KE, LB, LE, NAM, NXTLN LOGICAL PMEOF * .. External Functions .. LOGICAL LNCMP, GETWRD INTEGER EOLN EXTERNAL LNCMP, GETWRD, EOLN * .. Parameters .. INTEGER NPM, NGB, NTMP, NERR PARAMETER ( NPM = 5, NERR = 6, NGB = 10, NTMP = 12 ) INTEGER NLNS, LLN PARAMETER ( NLNS = 14, LLN = 256 ) CHARACTER TMPNAM*( LLN ) PARAMETER ( TMPNAM = 'tmpgb.tmp' ) * .. Local Arrays .. CHARACTER PMLN*( LLN ), GBLN*( LLN ), GBNAM*( LLN ), $ STRS( NLNS, 2 )*( LLN ), BNAM( NLNS )*( LLN ) CHARACTER PMLNA( LLN ), GBLNA( LLN ), GBNAMA( LLN ), $ STRSA( LLN, NLNS, 2 ), BNAMA( LLN, NLNS ) EQUIVALENCE ( PMLN, PMLNA ), ( GBLN, GBLNA ), $ ( GBNAM, GBNAMA ), ( STRS, STRSA ), $ ( BNAM, BNAMA ) * .. Data statements .. DATA BNAM/ $'zgb02.f' ,'zgb03.f' ,'zgb04.f' ,'zgb05.f' , $'zgb06.f' ,'zgb07.f' ,'zgb08.f' ,'zgb09.f' , $'zgb90.f' ,' ',' ',' ', $'zgb91.f' ,' '/ DATA STRS/ $'zsymm.f' ,'zhemm.f' ,'zsyrk.f' ,'zherk.f' , $'zsyr2k.f' ,'zher2k.f' ,'ztrmm.f' ,'ztrsm.f' , $'zbigp.f' ,' ',' ',' ', $'zcld.f' ,' ', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( ZIP41 = $$ , ZIP42 = $$ ,', $'$ ZIP51 = $$ , ZIP52 = $$ ,', $'$ ZIP81 = $$ , ZIP82 = $$ , ZIP83 = $$ ,', $'$ ZIP91 = $$ , ZIP92 = $$ , ZIP93 = $$ )', $'PARAMETER ( LNSZ = $$ , NPRT = $$ , PRTSZ = $$ ,', $'$ LOLIM = $$ , ZP = $$ )' / * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. * 10 READ( NPM, FMT = 9000, END = 110 ) GBNAM IF( .NOT.GETWRD( GBNAMA, LLN, IB, IE ).OR. $ ( GBNAM( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * Check if the first word on the line is the name of a file that is * due to be changed. * 20 NAM = -1 PMEOF = .FALSE. DO 30, I = 1, NLNS IF( GBNAM( IB:IE ).EQ.STRS( I, 1 ) )THEN NAM = I IF( .NOT.GETWRD( BNAMA( 1, NAM ), LLN, LB, LE ) )THEN WRITE( NERR, FMT = * ) $ 'Benchmark routine name corresponding to ', $ GBNAM( IB:IE ), ' is missing in ZSBPM.' STOP END IF END IF 30 CONTINUE IF( NAM.EQ.-1 )THEN WRITE( NERR, FMT = * )'Unknown routine name: ', GBNAM( IB:IE ) STOP END IF * * Read the next non-blank/non-comment line from the input parameter * file. * 40 READ( NPM, FMT = 9000, END = 110 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 40 END IF * * Copy each line of the GEMM-Based file, except for the lines that * are due to be changed, to the temporary file TMPNAM. Copy the * lines that should be changed from the input parameter file. Check * that the lines in the parameter file are correct compared to STRS. * NXTLN = NAM IF( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN OPEN( NGB, FILE = BNAM( NAM )( LB:LE ), STATUS = 'OLD' ) OPEN( NTMP, FILE = TMPNAM, STATUS = 'NEW' ) 50 READ( NGB, FMT = 9000, END = 80 ) GBLN IF( LNCMP( GBLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN WRITE( NTMP, FMT = 9010 ) PMLN( 1:EOLN( PMLNA, LLN ) ) 60 READ( NPM, FMT = 9000, END = 70 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 60 END IF IF( .NOT.GETWRD( STRSA( 1, NXTLN+1, 1 ), LLN, KB, KE ).AND. $ ( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN+1, 2 ), LLN ) ) $ )THEN NXTLN = NXTLN + 1 END IF ELSE WRITE( NTMP, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) END IF GO TO 50 70 PMEOF = .TRUE. GO TO 50 80 CLOSE( NGB, STATUS = 'DELETE' ) CLOSE( NTMP, STATUS = 'KEEP' ) ELSE WRITE( NERR, FMT = * )'Error in parameter file: ' WRITE( NERR, FMT = * ) PMLN STOP END IF * * Write back the temporary file TMPNAM to the GEMM-Based file and * remove the temporary file. * OPEN( NTMP, FILE = TMPNAM, STATUS = 'OLD' ) OPEN( NGB, FILE = BNAM( NAM )( LB:LE ), STATUS = 'NEW' ) 90 READ( NTMP, FMT = 9000, END = 100 ) GBLN WRITE( NGB, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) GO TO 90 100 CONTINUE CLOSE( NTMP, STATUS = 'DELETE' ) CLOSE( NGB, STATUS = 'KEEP' ) GBNAM = PMLN IB = JB IE = JE * IF( .NOT.PMEOF )THEN GO TO 20 END IF 110 CONTINUE * STOP * 9000 FORMAT( A ) 9010 FORMAT( A ) * * End of DSGPM. * END LOGICAL FUNCTION LNCMP( LN1, LEN1, LN2, LEN2 ) * .. Scalar Arguments .. INTEGER LEN1, LEN2 * .. Array Arguments .. CHARACTER LN1( LEN1 ), LN2( LEN2 ) * * Compare the character strings LN1 and LN2. Return .TRUE. if the * strings are identical except from wild cards ($$) corresponding * to positive integers and except from a different number of * consecutive blanks between tokens. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER I, J LOGICAL MATCH * .. Intrinsic Functions .. INTRINSIC LGE, LLE LOGICAL LGE, LLE * .. * .. Executable Statements .. * * Find the beginning of the next tokens in LN1 and LN2. * I = 1 J = 1 10 IF( ( LN1( I ).EQ.' ' ).AND.( I.LT.LEN1 ) )THEN I = I + 1 GO TO 10 END IF 20 IF( ( LN2( J ).EQ.' ' ).AND.( J.LT.LEN2 ) )THEN J = J + 1 GO TO 20 END IF * * Compare the tokens. * IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.LT.LEN1 ).AND. $ ( J.LT.LEN2 ) )THEN I = I + 1 J = J + 1 GO TO 10 ELSE IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.EQ.LEN1 ).AND. $ ( J.EQ.LEN2 ) )THEN LNCMP = .TRUE. RETURN ELSE IF( ( I.EQ.LEN1 ).AND.( J.EQ.LEN2 ) )THEN LNCMP = .FALSE. RETURN ELSE IF( LN1( I ).EQ.'$' )THEN IF( I.LT.LEN1-1 )THEN IF( LN1( I+1 ).EQ.'$' )THEN I = I + 2 MATCH = .FALSE. 30 IF( ( LGE( LN2( J ), '0' ).AND.LLE( LN2( J ), '9' ) ) $ .AND.( J.LT.LEN2 ) )THEN J = J + 1 MATCH = .TRUE. GO TO 30 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 ELSE IF( LN2( J ).EQ.'$' )THEN IF( J.LT.LEN2-1 )THEN IF( LN2( J+1 ).EQ.'$' )THEN J = J + 2 MATCH = .FALSE. 40 IF( ( LGE( LN1( I ), '0' ).AND.LLE( LN1( I ), '9' ) ) $ .AND.( I.LT.LEN1 ) )THEN I = I + 1 MATCH = .TRUE. GO TO 40 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 END IF * LNCMP = .FALSE. RETURN * * End of LNCMP. * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'make.gbinc' then echo shar: will not over-write existing file "'make.gbinc'" else cat << SHAR_EOF > 'make.gbinc' include ../../make.inc ### GEMM-Based Level 3 BLAS library and benchmark ######################## # # The following libraries are specified, the GEMM-based level 3 BLAS # library produced (GBL3B), the library with the underlying BLAS # routines used (ULIB), and the library with the timing functions SECOND # and DSECND (UTMG). # # CRETMG specifies if a timing library are to be created using the # implementations of SECOND and DSECND stored in the subdirectory # TMGLIB. # ULIB = $(USELIB) UULIB = $(USEULIB) UTMG = $(USETMG) GBL3B = $(CREGBLIB) CTMG = $(CRETMG) # ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # GBOPT : the GEMM-based level 3 BLAS routines # GBBOPT : the GEMM-based performance benchmark programs # AXOPT : various auxiliary routines # GBOPT = $(GBL3BOPT) GBBOPT = $(GBBENOPT) AXOPT = $(AUXOPT) SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'GBL3B' then mkdir 'GBL3B' fi cd 'GBL3B' if test ! -d 'CGBL3B' then mkdir 'CGBL3B' fi cd 'CGBL3B' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # CGBFLG : the GEMM-based level 3 BLAS routines # CAXFLG : GEMM-based specific auxiliary routines # AXOPT : other auxiliary routines # CGBFLG = $(GBOPT) CAXFLG = $(GBOPT) AXFLG = $(AXOPT) # ### GEMM-based Level 3 BLAS ############################################## CGBS = csymm.f chemm.f csyrk.f cherk.f csyr2k.f cher2k.f \ ctrmm.f ctrsm.f CGB = csymm.o chemm.o csyrk.o cherk.o csyr2k.o cher2k.o \ ctrmm.o ctrsm.o CAUXS = cbigp.f ccld.f CAUX = cbigp.o ccld.o AUXS = lsame.f xerbla.f AUX = lsame.o xerbla.o CGPMS = csgpm.f getwrd.f eoln.f CGPM = csgpm.o getwrd.o eoln.o ######################################################################## all: $(GBL3B) csgpm $(GBL3B): $(CGB) $(CAUX) $(AUX) $(ARCH) $(ARCHFLAGS) $(GBL3B) $(CGB) $(CAUX) $(AUX) $(RANLIB) $(GBL3B) csgpm: $(CGPM) $(LOADER) $(LOADOPT) -o csgpm $(CGPM) $(CGB): $(CGBS) $(FORTRAN) -c $(CGBFLG) $(CGBS) $(CAUX): $(CAUXS) $(FORTRAN) -c $(CAXFLG) $(CAUXS) $(AUX): $(AUXS) $(FORTRAN) -c $(AXFLG) $(AUXS) $(CGPM): $(CGPMS) $(FORTRAN) -c $(AXFLG) $(CGPMS) clean: rm -f *.o csgpm SHAR_EOF fi # end of overwriting check if test -f 'cbigp.f' then echo shar: will not over-write existing file "'cbigp.f'" else cat << SHAR_EOF > 'cbigp.f' LOGICAL FUNCTION CBIGP ( IP, DIM1, DIM2 ) * .. Scalar Arguments .. INTEGER IP, DIM1, DIM2 * .. * * Purpose * ======= * * CBIGP determines which of two alternative code sections in a GEMM- * Based Level 3 BLAS routine that will be the fastest for a particular * problem. If the problem is considered large enough CBIGP returns * .TRUE., otherwise .FALSE. is returned. The input parameter IP * specifies the calling routine and a break point for alternative code * sections. The input parameters DIM1 and DIM2 are matrix dimensions. * The returned value is a function of the input parameters and the * performance characteristics of the two alternative code sections. * * In this simple implementation, the returned values are determined by * looking at only one of the two dimensions DIM1 and DIM2. It may be * rewarding to rewrite the logical expressions in CBIGP so that both * dimensions are involved. The returned values should effectively * reflect the performance characteristics of the underlying BLAS * routines. * * * Input * ===== * * IP - INTEGER * On entry, IP specifies which routine and which alternative * code sections that the decision is intended for. * Unchanged on exit. * * DIM1 - INTEGER. * On entry, DIM1 specifies the first dimension in the calling * sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * DIM2 - INTEGER. * On entry, DIM2 specifies the second dimension in the * calling sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. User specified parameters for CBIGP .. INTEGER CIP41, CIP42, $ CIP51, CIP52, $ CIP81, CIP82, CIP83, $ CIP91, CIP92, CIP93 PARAMETER ( CIP41 = 4, CIP42 = 3, $ CIP51 = 4, CIP52 = 3, $ CIP81 = 4, CIP82 = 3, CIP83 = 4, $ CIP91 = 4, CIP92 = 3, CIP93 = 4 ) * .. * .. Executable Statements .. IF( IP.EQ.41 )THEN CBIGP = DIM1.GE.CIP41 ELSE IF( IP.EQ.42 )THEN CBIGP = DIM2.GE.CIP42 ELSE IF( IP.EQ.51 )THEN CBIGP = DIM1.GE.CIP51 ELSE IF( IP.EQ.52 )THEN CBIGP = DIM2.GE.CIP52 ELSE IF( IP.EQ.81 )THEN CBIGP = DIM2.GE.CIP81 ELSE IF( IP.EQ.82 )THEN CBIGP = DIM2.GE.CIP82 ELSE IF( IP.EQ.83 )THEN CBIGP = DIM1.GE.CIP83 ELSE IF( IP.EQ.91 )THEN CBIGP = DIM2.GE.CIP91 ELSE IF( IP.EQ.92 )THEN CBIGP = DIM2.GE.CIP92 ELSE IF( IP.EQ.93 )THEN CBIGP = DIM1.GE.CIP93 ELSE CBIGP = .FALSE. END IF * RETURN * * End of CBIGP. * END SHAR_EOF fi # end of overwriting check if test -f 'ccld.f' then echo shar: will not over-write existing file "'ccld.f'" else cat << SHAR_EOF > 'ccld.f' LOGICAL FUNCTION CCLD ( LD ) * .. Scalar Arguments .. INTEGER LD * .. * * Purpose * ======= * * The size of the leading dimension of a two-dimensional array may * cause severe problems. Often when an array with a 'critical' leading * dimension is referenced, the execution time becomes significantly * longer than expected. This is caused by shortcomings of the memory * system. * * The function CCLD returns .TRUE. if the leading dimension LD is * critical and .FALSE. if it is not critical. In this implementation * CCLD is designed to detect critical leading dimensions in an * environment with a multi-way associative cache. Parameters defining * cache characteristics are adjustable to match different machines. * It may be rewarding to rewrite CCLD for a machine with a different * cache policy. * * The cache lines in a multi-way associative cache are divided among a * number of partitions, each containing the same number of lines. Each * address of main memory is mapped into a particular partition. The * number of lines in a partition equals the associativity. For example, * in a four way associative cache, each partition contain four cache * lines. * * Data are transferred between the cache and main memory according to * an associative mapping scheme. A transfer of a data word from main * memory to cache is accomplished as follows. A unit of data * (data line) in main memory, with the size of a cache line, and * containing several contiguous data words including the referenced * one, is mapped (copied) to a certain partition in the cache memory. * The partition is determined by the location of the element in the * main memory and the associative mapping scheme. A replacement * algorithm makes room for the data line in one of the cache lines in * the selected partition. For example, an LRU-based (Least Recently * Used) replacement algorithm places the data line in the least * recently 'touched' cache line in the selected partition. * * * Input * ===== * * LD - On entry, LD specifies the leading dimension of a * 2-dimensional array. Unchanged on exit. * * * User specified parameters for CCLD * ================================ * * LNSZ - Size of a cache line in number of bytes. * * NPRT - Number of partitions in the cache memory. * * PRTSZ - The number of cache lines in a partition that can be used * exclusively to hold a local array containing a matrix block * during the execution of a GEMM-Based Level 3 BLAS routine. * The remaining cache lines may be occupied by scalars, * vectors and possibly program code depending on the system. * * LOLIM - Leading dimensions smaller than or equal to LOLIM are not * considered critical. * * CP - Number of bytes in a complex-precision word. * * * Local Variables and Parameters * ============================== * * ONEWAY - The maximum number of real words that can be * stored in the cache memory if only a single cache line in * each partition may be used. * * UPDIF - The difference between the multiple of LD that is nearest * ONEWAY, or nearest a multiple of ONEWAY, and the nearest * multiple of ONEWAY that is larger than LD. In number of * real words. * * MXDIF - If both UPDIF and LD - UPDIF are less than MXDIF, and LD * is greater than LOLIM, then the leading dimension is * considered critical. Otherwise, the leading dimension is * considered not critical. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Variables .. INTEGER UPDIF * .. Intrinsic Functions .. INTRINSIC MIN, MOD * .. User specified parameters for CCLD .. INTEGER LOLIM, LNSZ, NPRT, PRTSZ, CP PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, CP = 8 ) * .. Parameters .. INTEGER ONEWAY, MXDIF PARAMETER ( ONEWAY = ( LNSZ*NPRT )/CP, $ MXDIF = LNSZ/( CP*PRTSZ ) ) * .. * .. Executable Statements .. * IF( LD.LE.LOLIM )THEN CCLD = .FALSE. ELSE UPDIF = MOD( ( LD/ONEWAY )*ONEWAY+ONEWAY, LD ) CCLD = MIN( UPDIF, LD-UPDIF ).LE.MXDIF END IF * RETURN * * End of CCLD. * END SHAR_EOF fi # end of overwriting check if test -f 'cgpm.in' then echo shar: will not over-write existing file "'cgpm.in'" else cat << SHAR_EOF > 'cgpm.in' * * Example of an input file for the program CSGPM containing user * specified parameters. * * The enclosed program CSGPM re-writes GEMM-Based Level 3 BLAS source * files replacing lines containing old PARAMETER statements for user * specified parameters, with lines containing new PARAMETER statements * given in an input file. The user can conveniently assign new values * to the PARAMETER statements in the input file, and then run CSGPM to * distribute these values to the GEMM-based routines. An input file * consists of three different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file. Read the file * INSTALL for further instructions on how to use this file. * csymm.f PARAMETER ( RCB = 128, CB = 64 ) chemm.f PARAMETER ( RCB = 128, CB = 64 ) csyr2k.f PARAMETER ( RCB = 128, CB = 64 ) cher2k.f PARAMETER ( RCB = 128, CB = 64 ) csyrk.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) cherk.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) ctrmm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) ctrsm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) cbigp.f PARAMETER ( CIP41 = 4, CIP42 = 3, $ CIP51 = 4, CIP52 = 3, $ CIP81 = 4, CIP82 = 3, CIP83 = 4, $ CIP91 = 4, CIP92 = 3, CIP93 = 4 ) ccld.f PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, CP = 8 ) SHAR_EOF fi # end of overwriting check if test -f 'chemm.f' then echo shar: will not over-write existing file "'chemm.f'" else cat << SHAR_EOF > 'chemm.f' SUBROUTINE CHEMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CHEMM performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is an hermitian matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the hermitian matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the hermitian matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * hermitian matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * hermitian matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the hermitian matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the hermitian matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the hermitian * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the hermitian matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the hermitian matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the hermitian * matrix and the strictly upper triangular part of A is not * referenced. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - COMPLEX . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN, REAL, CMPLX, CONJG * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CCOPY * .. Parameters .. REAL ZERO COMPLEX CZERO, CONE PARAMETER ( ZERO = 0.0E+0, $ CZERO = ( 0.0E+0, 0.0E+0 ), $ CONE = ( 1.0E+0, 0.0E+0 ) ) * .. User specified parameters for CHEMM .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CHEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.CZERO ).AND.( BETA.EQ.CONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.CZERO )THEN CALL CGEMM ( 'N', 'N', M, N, 0, CZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 60, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 20, I = 1, ISEC T1( I, I ) = CMPLX( REAL( T1( I, I ) ), ZERO ) 20 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly upper triangular diagonal block of A is copied * to the strictly lower triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 50, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 40, J = JJ+1, II+ISEC-1 DO 30, I = JJ, J-1 T1( J-II+1, I-II+1 ) = CONJG( A( I, J ) ) 30 CONTINUE 40 CONTINUE 50 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*conjg( A' )*B + C and C := alpha*A*B + C, * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL CGEMM ( 'C', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ CONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, CONE, C( II, 1 ), LDC ) END IF 60 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 120, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 70, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 70 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 80, I = 1, ISEC T1( I, I ) = CMPLX( REAL( T1( I, I ) ), ZERO ) 80 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly lower triangular diagonal block of A is copied * to the strictly upper triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 110, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 100, J = II, JJ+JSEC-2 DO 90, I = J+1, II+ISEC-1 T1( J-II+1, I-II+1 ) = CONJG( A( I, J ) ) 90 CONTINUE 100 CONTINUE 110 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*conjg( A' )*B + C and C := alpha*A*B + C, * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'C', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, CONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ CONE, C( II, 1 ), LDC ) END IF 120 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 180, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL CCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 130 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 140, J = 1, JSEC T1( J, J ) = CMPLX( REAL( T1( J, J ) ), ZERO ) 140 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly upper triangular diagonal block of A is copied * to the strictly lower triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 170, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 160, I = II+1, JJ+JSEC-1 DO 150, J = II, I-1 T1( I-JJ+1, J-JJ+1 ) = CONJG( A( J, I ) ) 150 CONTINUE 160 CONTINUE 170 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*conjg( A' ) + C, * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ CONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'C', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, CONE, C( 1, JJ ), LDC ) END IF 180 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 240, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 190, J = JJ, JJ+JSEC-1 CALL CCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 190 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 200, J = 1, JSEC T1( J, J ) = CMPLX( REAL( T1( J, J ) ), ZERO ) 200 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly lower triangular diagonal block of A is copied * to the strictly upper triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 230, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 220, I = JJ, II+ISEC-2 DO 210, J = I+1, JJ+JSEC-1 T1( I-JJ+1, J-JJ+1 ) = CONJG( A( J, I ) ) 210 CONTINUE 220 CONTINUE 230 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*conjg( A' ) + C, * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, CONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'C', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ CONE, C( 1, JJ ), LDC ) END IF 240 CONTINUE END IF END IF * RETURN * * End of CHEMM. * END SHAR_EOF fi # end of overwriting check if test -f 'cher2k.f' then echo shar: will not over-write existing file "'cher2k.f'" else cat << SHAR_EOF > 'cher2k.f' SUBROUTINE CHER2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC REAL BETA COMPLEX ALPHA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CHER2K performs one of the hermitian rank 2k operations * * C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, * * or * * C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, * * where alpha and beta are scalars with beta real, C is an n by n * hermitian matrix and A and B are n by k matrices in the first case * and k by n matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + * conjg( alpha )*B*conjg( A' ) + * beta*C. * * TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + * conjg( alpha )*conjg( B' )*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'C' or 'c', K specifies the number of rows of the * matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC LOGICAL UPPER, NOTR COMPLEX CBETA * .. Intrinsic Functions .. INTRINSIC MIN, MAX, REAL, CMPLX, CONJG * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CAXPY, CSCAL * .. Parameters .. REAL ONE, ZERO COMPLEX CONE, CZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, $ CONE = ( 1.0E+0, 0.0E+0 ), $ CZERO = ( 0.0E+0, 0.0E+0 ) ) * .. User specified parameters for CHER2K .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CHER2K', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.CZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * CBETA = CMPLX( BETA, ZERO ) * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.CZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN C( 1, 1 ) = CMPLX( BETA*REAL( C( 1, 1 ) ), ZERO ) DO 10, I = 2, N CALL CSCAL ( I-1, CBETA, C( 1, I ), 1 ) C( I, I ) = CMPLX( BETA*REAL( C( I, I ) ), ZERO ) 10 CONTINUE ELSE DO 20, I = 1, N-1 C( I, I ) = CMPLX( BETA*REAL( C( I, I ) ), ZERO ) CALL CSCAL ( N-I, CBETA, C( I+1, I ), 1 ) 20 CONTINUE C( N, N ) = CMPLX( BETA*REAL( C( N, N ) ), ZERO ) END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*conjg( B' ) + * conjg( alpha )*B*conjg( A' ) + beta*C. Upper, Notr. * DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL CGEMM ( 'N', 'C', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, CZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, CBETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL CAXPY ( I-II+1, CONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * lower triangular part of T1 is added to the upper * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by CAXPY is CB. * DO 70, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 60, I = JJ, II+ISEC-1 DO 50, J = JJ, MIN( JJ+JSEC-1, I ) C( J, I ) = C( J, I ) + $ CONJG( T1( I-II+1, J-II+1 ) ) 50 CONTINUE 60 CONTINUE 70 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 80, I = II, II+ISEC-1 C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 80 CONTINUE * * C := alpha*A*conjg( B' ) + beta*C and * C := conjg( alpha )*B*conjg( A' ) + C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'C', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, CBETA, $ C( 1, II ), LDC ) CALL CGEMM ( 'N', 'C', II-1, ISEC, K, CONJG( ALPHA ), $ B( 1, 1 ), LDB, A( II, 1 ), LDA, CONE, $ C( 1, II ), LDC ) END IF 90 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B + * conjg( alpha )*conjg( B' )*A + beta*C. Upper, Trans. * DO 160, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*conjg( A' )*B, matrix multiply on * rectangular blocks of A and B. T1 is a square block. * CALL CGEMM ( 'C', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, CZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 100, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, CBETA, C( II, I ), 1 ) 100 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 110, I = II, II+ISEC-1 CALL CAXPY ( I-II+1, CONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 110 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * lower triangular part of T1 is added to the upper * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by CAXPY is CB. * DO 140, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 130, I = JJ, II+ISEC-1 DO 120, J = JJ, MIN( JJ+JSEC-1, I ) C( J, I ) = C( J, I ) + $ CONJG( T1( I-II+1, J-II+1 ) ) 120 CONTINUE 130 CONTINUE 140 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 150, I = II, II+ISEC-1 C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 150 CONTINUE * * C := alpha*conjg( A' )*B + beta*C and * C := alpha*conjg( B' )*A + C, matrix multiply on upper * vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'C', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, CBETA, $ C( 1, II ), LDC ) CALL CGEMM ( 'C', 'N', II-1, ISEC, K, CONJG( ALPHA ), $ B( 1, 1 ), LDB, A( 1, II ), LDA, CONE, $ C( 1, II ), LDC ) END IF 160 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*conjg( B' ) + * alpha*B*conjg( A' ) + beta*C. Lower, Notr. * DO 230, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL CGEMM ( 'N', 'C', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, CZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 170, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, CBETA, C( I, I ), 1 ) 170 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 180, I = II, II+ISEC-1 CALL CAXPY ( II+ISEC-I, CONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 180 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * upper triangular part of T1 is added to the lower * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by CAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 DO 190, J = MAX( JJ, I), JJ+JSEC-1 C( J, I ) = C( J, I ) + $ CONJG( T1( I-II+1, J-II+1 ) ) 190 CONTINUE 200 CONTINUE 210 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 220, I = II, II+ISEC-1 C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 220 CONTINUE * * C := alpha*A*conjg( B' ) + beta*C and * C := alpha*B*conjg( A' ) + C, matrix multiply on lower * vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ CBETA, C( II+ISEC, II ), LDC ) CALL CGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ CONJG( ALPHA ), B( II+ISEC, 1 ), LDB, A( II, 1 ), $ LDA, CONE, C( II+ISEC, II ), LDC ) END IF 230 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B + * alpha*conjg( B' )*A + beta*C. Lower, Trans. * DO 300, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL CGEMM ( 'C', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, CZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 240, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, CBETA, C( I, I ), 1 ) 240 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 250, I = II, II+ISEC-1 CALL CAXPY ( II+ISEC-I, CONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 250 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * upper triangular part of T1 is added to the lower * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by CAXPY is CB. * DO 280, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 270, I = II, JJ+JSEC-1 DO 260, J = MAX( JJ, I), JJ+JSEC-1 C( J, I ) = C( J, I ) + $ CONJG( T1( I-II+1, J-II+1 ) ) 260 CONTINUE 270 CONTINUE 280 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 290, I = II, II+ISEC-1 C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 290 CONTINUE * * C := alpha*conjg( A' )*B + beta*C and * C := alpha*conjg( B' )*A + C, matrix multiply on lower * vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ CBETA, C( II+ISEC, II ), LDC ) CALL CGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ CONJG( ALPHA ), B( 1, II+ISEC ), LDB, A( 1, II ), $ LDA, CONE, C( II+ISEC, II ), LDC ) END IF 300 CONTINUE END IF END IF * RETURN * * End of CHER2K. * END SHAR_EOF fi # end of overwriting check if test -f 'cherk.f' then echo shar: will not over-write existing file "'cherk.f'" else cat << SHAR_EOF > 'cherk.f' SUBROUTINE CHERK ( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC REAL ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * CHERK performs one of the hermitian rank k operations * * C := alpha*A*conjg( A' ) + beta*C, * * or * * C := alpha*conjg( A' )*A + beta*C, * * where alpha and beta are real scalars, C is an n by n hermitian * matrix and A is an n by k matrix in the first case and a k by n * matrix in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. * * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'C' or 'c', K specifies the number of rows of the * matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK COMPLEX CALPHA, CBETA, CDELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX, REAL, CMPLX, CONJG * .. External Functions .. LOGICAL LSAME, CBIGP, CCLD EXTERNAL LSAME, CBIGP, CCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CGEMV, CHER, CCOPY, CSCAL * .. Parameters .. REAL ONE, ZERO COMPLEX CONE INTEGER CIP51, CIP52 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, $ CONE = ( 1.0E+0, 0.0E+0 ), $ CIP51 = 51, CIP52 = 52 ) * .. User specified parameters for CHERK .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ), $ T4( CB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CHERK ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * CALPHA = CMPLX( ALPHA, ZERO ) CBETA = CMPLX( BETA, ZERO ) * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN C( 1, 1 ) = CMPLX( BETA*REAL( C( 1, 1 ) ), ZERO ) DO 10, I = 2, N CALL CSCAL ( I-1, CBETA, C( 1, I ), 1 ) C( I, I ) = CMPLX( BETA*REAL( C( I, I ) ), ZERO ) 10 CONTINUE ELSE DO 20, I = 1, N-1 C( I, I ) = CMPLX( BETA*REAL( C( I, I ) ), ZERO ) CALL CSCAL ( N-I, CBETA, C( I+1, I ), 1 ) 20 CONTINUE C( N, N ) = CMPLX( BETA*REAL( C( N, N ) ), ZERO ) END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*conjg( A' ) + beta*C. Upper, Notr. * SMALLN = .NOT.CBIGP( CIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CBIGP( CIP52 , N, K ) DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'C', II-1, ISEC, K, CALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ CBETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN C( II, II ) = $ CMPLX( BETA*REAL( C( II, II ) ), ZERO ) DO 30, I = II+1, II+ISEC-1 CALL CSCAL ( I-II, CBETA, C( II, I ), 1 ) C( I, I ) = $ CMPLX( BETA*REAL( C( I, I ) ), ZERO ) 30 CONTINUE END IF * * C := alpha*A*conjg( A' ) + C, hermitian matrix * multiply. C is a hermitian diagonal block having * upper triangular storage format. * DO 40, L = 1, K CALL CHER ( 'U', ISEC, ALPHA, A( II, L ), $ 1, C( II, II ), LDC ) 40 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * hermitian matrix C is copied to the upper * triangular part of T2. * DO 50, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 50 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. The imaginary part of the * diagonal elements of T2 are set to ZERO. * IF( BETA.NE.ONE )THEN T2( 1, 1 ) = $ CMPLX( BETA*REAL( T2( 1, 1 ) ), ZERO ) DO 60, I = 2, ISEC CALL CSCAL ( I-1, CBETA, T2( 1, I ), 1 ) T2( I, I ) = $ CMPLX( BETA*REAL( T2( I, I ) ), ZERO ) 60 CONTINUE END IF * * T2 := alpha*A*conjg( A' ) + T2, hermitian matrix * multiply. T2 contains a hermitian block having * upper triangular storage format. * DO 70, L = 1, K CALL CHER ( 'U', ISEC, ALPHA, A( II, L ), $ 1, T2( 1, 1 ), RCB ) 70 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 80, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 80 CONTINUE END IF 90 CONTINUE ELSE DO 140, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'C', II-1, ISEC, K, CALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ CBETA, C( 1, II ), LDC ) END IF CDELTA = CBETA DO 130, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 100, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 100 CONTINUE * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 120, I = II, II+ISEC-1 DO 110, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ CONJG( T1( I-II+1, L-LL+1 ) ) 110 CONTINUE CALL CGEMV ( 'N', I-II+1, LSEC, CALPHA, $ T1( 1, 1 ), RB, T4( 1 ), 1, $ CDELTA, C( II, I ), 1 ) C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 120 CONTINUE CDELTA = CONE 130 CONTINUE 140 CONTINUE END IF ELSE * * Form C := alpha*conjg( A' )*A + beta*C. Upper, Trans. * SMALLN = .NOT.CBIGP( CIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CBIGP( CIP52 , N, K ) DO 250, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'C', 'N', II-1, ISEC, K, CALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ CBETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN C( II, II ) = $ CMPLX( BETA*REAL( C( II, II ) ), ZERO ) DO 150, I = II+1, II+ISEC-1 CALL CSCAL ( I-II, CBETA, C( II, I ), 1 ) C( I, I ) = $ CMPLX( BETA*REAL( C( I, I ) ), ZERO ) 150 CONTINUE END IF * * C := alpha*conjg( A' )*A + C, hermitian matrix * multiply. C is a hermitian diagonal block having * upper triangular storage format. The local array * T3 is used for temporary storage of the conjugate * transposed vectors of A. * DO 170, L = 1, K DO 160, I = II, II+ISEC-1 T3( I-II+1, 1 ) = CONJG( A( L, I ) ) 160 CONTINUE CALL CHER ( 'U', ISEC, ALPHA, T3( 1, 1 ), $ 1, C( II, II ), LDC ) 170 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * hermitian matrix C is copied to the upper * triangular part of T2. * DO 180, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 180 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 190, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, CBETA, $ T2( 1, I-II+1 ), 1 ) 190 CONTINUE END IF DO 230, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 200, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 200 CONTINUE * * T2 := alpha*conjg( T3' )*T3 + T2, hermitian * matrix multiply. T2 contains a hermitian block * having upper triangular storage format. The * local array T3 is used for temporary storage of * the conjugate transposed vectors of A. * DO 220, L = LL, LL+LSEC-1 DO 210, I = 1, ISEC T3( I, L-LL+1 ) = $ CONJG( T3( I, L-LL+1 ) ) 210 CONTINUE CALL CHER ( 'U', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 220 CONTINUE 230 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 240, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 240 CONTINUE END IF 250 CONTINUE ELSE CLDA = CCLD( LDA ) DO 330, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'C', 'N', II-1, ISEC, K, CALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ CBETA, C( 1, II ), LDC ) END IF CDELTA = CBETA DO 320, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := conjg( A' ), the conjugated transpose of a * rectangular block of A is copied to T1. * IF( CLDA )THEN DO 270, I = II, II+ISEC-1 DO 260, L = LL, LL+LSEC-1 T1( I-II+1, L-LL+1 ) = $ CONJG( A( L, I ) ) 260 CONTINUE 270 CONTINUE ELSE DO 290, L = LL, LL+LSEC-1 DO 280, I = II, II+ISEC-1 T1( I-II+1, L-LL+1 ) = $ CONJG( A( L, I ) ) 280 CONTINUE 290 CONTINUE END IF * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 310, I = II, II+ISEC-1 DO 300, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ CONJG( T1( I-II+1, L-LL+1 ) ) 300 CONTINUE CALL CGEMV ( 'N', I-II+1, LSEC, CALPHA, $ T1( 1, 1 ), RB, T4( 1 ), 1, $ CDELTA, C( II, I ), 1 ) C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 310 CONTINUE CDELTA = CONE 320 CONTINUE 330 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*conjg( A' ) + beta*C. Lower, Notr. * SMALLN = .NOT.CBIGP( CIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CBIGP( CIP52 , N, K ) DO 400, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 340, I = II, II+ISEC-2 C( I, I ) = $ CMPLX( BETA*REAL( C( I, I ) ), ZERO ) CALL CSCAL ( II+ISEC-I-1, CBETA, $ C( I+1, I ), 1 ) 340 CONTINUE C( II+ISEC-1, II+ISEC-1 ) = $ CMPLX( BETA*REAL( C( II+ISEC-1, $ II+ISEC-1 ) ), ZERO ) END IF * * C := alpha*A*conjg( A' ) + C, hermitian matrix * multiply. C is a hermitian diagonal block having * lower triangular storage format. * DO 350, L = 1, K CALL CHER ( 'L', ISEC, ALPHA, A( II, L ), $ 1, C( II, II ), LDC ) 350 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * hermitian matrix C is copied to the lower * triangular part of T2. * DO 360, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 360 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. The imaginary part of the * diagonal elements of T2 are set to ZERO. * IF( BETA.NE.ONE )THEN DO 370, I = 1, ISEC-1 T2( I, I ) = $ CMPLX( BETA*REAL( T2( I, I ) ), ZERO ) CALL CSCAL ( ISEC-I, CBETA, $ T2( I+1, I ), 1 ) 370 CONTINUE T2( ISEC, ISEC ) = $ CMPLX( BETA*REAL( T2( ISEC, ISEC ) ), $ ZERO ) END IF * * T2 := alpha*A*conjg( A' ) + T2, symmetric matrix * multiply. T2 contains a hermitian block having * lower triangular storage format. * DO 380, L = 1, K CALL CHER ( 'L', ISEC, ALPHA, A( II, L ), $ 1, T2( 1, 1 ), RCB ) 380 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 390, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ CALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, CBETA, C( II+ISEC, II ), LDC ) END IF 400 CONTINUE ELSE DO 450, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 CDELTA = CBETA DO 440, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 410, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 410 CONTINUE * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 430, I = II, II+ISEC-1 DO 420, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ CONJG( T1( I-II+1, L-LL+1 ) ) 420 CONTINUE CALL CGEMV ( 'N', II+ISEC-I, LSEC, CALPHA, $ T1( I-II+1, 1 ), RB, T4( 1 ), 1, $ CDELTA, C( I, I ), 1 ) C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 430 CONTINUE CDELTA = CONE 440 CONTINUE * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ CALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, CBETA, C( II+ISEC, II ), LDC ) END IF 450 CONTINUE END IF ELSE * * Form C := alpha*conjg( A' )*A + beta*C. Lower, Trans. * SMALLN = .NOT.CBIGP( CIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CBIGP( CIP52 , N, K ) DO 560, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN DO 460, I = II, II+ISEC-2 C( I, I ) = $ CMPLX( BETA*REAL( C( I, I ) ), ZERO ) CALL CSCAL ( II+ISEC-I-1, CBETA, $ C( I+1, I ), 1 ) 460 CONTINUE C( II+ISEC-1, II+ISEC-1 ) = $ CMPLX( BETA*REAL( C( II+ISEC-1, $ II+ISEC-1 ) ), ZERO ) END IF * * C := alpha*conjg( A' )*A + C, hermitian matrix * multiply. C is a hermitian diagonal block having * lower triangular storage format. The local array * T3 is used for temporary storage of the conjugate * transposed vectors of A. * DO 480, L = 1, K DO 470, I = II, II+ISEC-1 T3( I-II+1, 1 ) = CONJG( A( L, I ) ) 470 CONTINUE CALL CHER ( 'L', ISEC, ALPHA, T3( 1, 1 ), $ 1, C( II, II ), LDC ) 480 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 490, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 490 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 500, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, CBETA, $ T2( I-II+1, I-II+1 ), 1 ) 500 CONTINUE END IF DO 540, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 510, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 510 CONTINUE * * T2 := alpha*conjg( T3' )*T3 + T2, hermitian * matrix multiply. T2 contains a hermitian block * having lower triangular storage format. The * local array T3 is used for temporary storage of * the conjugate transposed vectors of A. * DO 530, L = LL, LL+LSEC-1 DO 520, I = 1, ISEC T3( I, L-LL+1 ) = $ CONJG( T3( I, L-LL+1 ) ) 520 CONTINUE CALL CHER ( 'L', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 530 CONTINUE 540 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 550, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 550 CONTINUE END IF * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ CALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, CBETA, C( II+ISEC, II ), LDC ) END IF 560 CONTINUE ELSE CLDA = CCLD( LDA ) DO 650, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 CDELTA = CBETA DO 640, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := conjg( A' ), the conjugated transpose of a * rectangular block of A is copied to T1. * IF( CLDA )THEN DO 580, I = II, II+ISEC-1 DO 570, L = LL, LL+LSEC-1 T1( I-II+1, L-LL+1 ) = $ CONJG( A( L, I ) ) 570 CONTINUE 580 CONTINUE ELSE DO 600, L = LL, LL+LSEC-1 DO 590, I = II, II+ISEC-1 T1( I-II+1, L-LL+1 ) = $ CONJG( A( L, I ) ) 590 CONTINUE 600 CONTINUE END IF * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 630, I = II, II+ISEC-1 DO 620, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ CONJG( T1( I-II+1, L-LL+1 ) ) 620 CONTINUE CALL CGEMV ( 'N', II+ISEC-I, LSEC, CALPHA, $ T1( I-II+1, 1 ), RB, T4( 1 ), 1, $ CDELTA, C( I, I ), 1 ) C( I, I ) = CMPLX( REAL( C( I, I ) ), ZERO ) 630 CONTINUE CDELTA = CONE 640 CONTINUE * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ CALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, CBETA, C( II+ISEC, II ), LDC ) END IF 650 CONTINUE END IF END IF END IF * RETURN * * End of CHERK. * END SHAR_EOF fi # end of overwriting check if test -f 'csgpm.f' then echo shar: will not over-write existing file "'csgpm.f'" else cat << SHAR_EOF > 'csgpm.f' PROGRAM CSGPM * * CSGPM re-writes GEMM-Based Level 3 BLAS source files replacing lines * containing old PARAMETER statements for user specified parameters, * with lines containing new PARAMETER statements given in an input * file. The user can conveniently assign new values to the PARAMETER * statements in the input file, and then run CSGPM to distribute these * values to the GEMM-based routines. An input file consists of three * different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file (see the input file * 'sgpm.in'). Read the file INSTALL for further instructions. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, IB, IE, JB, JE, KB, KE, NAM, NXTLN LOGICAL PMEOF * .. External Functions .. LOGICAL LNCMP, GETWRD INTEGER EOLN EXTERNAL LNCMP, GETWRD, EOLN * .. Parameters .. INTEGER NPM, NGB, NTMP, NERR PARAMETER ( NPM = 5, NERR = 6, NGB = 10, NTMP = 12 ) INTEGER NLNS, LLN PARAMETER ( NLNS = 14, LLN = 256 ) CHARACTER TMPNAM*( LLN ) PARAMETER ( TMPNAM = 'tmpgb.tmp' ) * .. Local Arrays .. CHARACTER PMLN*( LLN ), GBLN*( LLN ), GBNAM*( LLN ), $ STRS( NLNS, 2 )*( LLN ) CHARACTER PMLNA( LLN ), GBLNA( LLN ), GBNAMA( LLN ), $ STRSA( LLN, NLNS, 2 ) EQUIVALENCE ( PMLN, PMLNA ), ( GBLN, GBLNA ), $ ( GBNAM, GBNAMA ), ( STRS, STRSA ) * .. Data statements .. DATA STRS/ $'csymm.f' ,'chemm.f' ,'csyrk.f' ,'cherk.f' , $'csyr2k.f' ,'cher2k.f' ,'ctrmm.f' ,'ctrsm.f' , $'cbigp.f' ,' ',' ',' ', $'ccld.f' ,' ', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( CIP41 = $$ , CIP42 = $$ ,', $'$ CIP51 = $$ , CIP52 = $$ ,', $'$ CIP81 = $$ , CIP82 = $$ , CIP83 = $$ ,', $'$ CIP91 = $$ , CIP92 = $$ , CIP93 = $$ )', $'PARAMETER ( LNSZ = $$ , NPRT = $$ , PRTSZ = $$ ,', $'$ LOLIM = $$ , CP = $$ )' / * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. * 10 READ( NPM, FMT = 9000, END = 110 ) GBNAM IF( .NOT.GETWRD( GBNAMA, LLN, IB, IE ).OR. $ ( GBNAM( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * Check if the first word on the line is the name of a file that is * due to be changed. * 20 NAM = -1 PMEOF = .FALSE. DO 30, I = 1, NLNS IF( GBNAM( IB:IE ).EQ.STRS( I, 1 ) )THEN NAM = I END IF 30 CONTINUE IF( NAM.EQ.-1 )THEN WRITE( NERR, FMT = * )'Unknown routine name: ', GBNAM( IB:IE ) STOP END IF * * Read the next non-blank/non-comment line from the input parameter * file. * 40 READ( NPM, FMT = 9000, END = 110 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 40 END IF * * Copy each line of the GEMM-Based file, except for the lines that * are due to be changed, to the temporary file TMPNAM. Copy the * lines that should be changed from the input parameter file. Check * that the lines in the parameter file are correct compared to STRS. * NXTLN = NAM IF( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN OPEN( NGB, FILE = GBNAM( IB:IE ), STATUS = 'OLD' ) OPEN( NTMP, FILE = TMPNAM, STATUS = 'NEW' ) 50 READ( NGB, FMT = 9000, END = 80 ) GBLN IF( LNCMP( GBLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN WRITE( NTMP, FMT = 9010 ) PMLN( 1:EOLN( PMLNA, LLN ) ) 60 READ( NPM, FMT = 9000, END = 70 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 60 END IF IF( .NOT.GETWRD( STRSA( 1, NXTLN+1, 1 ), LLN, KB, KE ).AND. $ ( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN+1, 2 ), LLN ) ) $ )THEN NXTLN = NXTLN + 1 END IF ELSE WRITE( NTMP, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) END IF GO TO 50 70 PMEOF = .TRUE. GO TO 50 80 CLOSE( NGB, STATUS = 'DELETE' ) CLOSE( NTMP, STATUS = 'KEEP' ) ELSE WRITE( NERR, FMT = * )'Error in parameter file: ' WRITE( NERR, FMT = * ) PMLN STOP END IF * * Write back the temporary file TMPNAM to the GEMM-Based file and * remove the temporary file. * OPEN( NTMP, FILE = TMPNAM, STATUS = 'OLD' ) OPEN( NGB, FILE = GBNAM( IB:IE ), STATUS = 'NEW' ) 90 READ( NTMP, FMT = 9000, END = 100 ) GBLN WRITE( NGB, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) GO TO 90 100 CONTINUE CLOSE( NTMP, STATUS = 'DELETE' ) CLOSE( NGB, STATUS = 'KEEP' ) GBNAM = PMLN IB = JB IE = JE * IF( .NOT.PMEOF )THEN GO TO 20 END IF 110 CONTINUE * STOP * 9000 FORMAT( A ) 9010 FORMAT( A ) * * End of SSGPM. * END LOGICAL FUNCTION LNCMP( LN1, LEN1, LN2, LEN2 ) * .. Scalar Arguments .. INTEGER LEN1, LEN2 * .. Array Arguments .. CHARACTER LN1( LEN1 ), LN2( LEN2 ) * * Compare the character strings LN1 and LN2. Return .TRUE. if the * strings are identical except from wild cards ($$) corresponding * to positive integers and except from a different number of * consecutive blanks between tokens. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER I, J LOGICAL MATCH * .. Intrinsic Functions .. INTRINSIC LGE, LLE LOGICAL LGE, LLE * .. * .. Executable Statements .. * * Find the beginning of the next tokens in LN1 and LN2. * I = 1 J = 1 10 IF( ( LN1( I ).EQ.' ' ).AND.( I.LT.LEN1 ) )THEN I = I + 1 GO TO 10 END IF 20 IF( ( LN2( J ).EQ.' ' ).AND.( J.LT.LEN2 ) )THEN J = J + 1 GO TO 20 END IF * * Compare the tokens. * IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.LT.LEN1 ).AND. $ ( J.LT.LEN2 ) )THEN I = I + 1 J = J + 1 GO TO 10 ELSE IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.EQ.LEN1 ).AND. $ ( J.EQ.LEN2 ) )THEN LNCMP = .TRUE. RETURN ELSE IF( ( I.EQ.LEN1 ).AND.( J.EQ.LEN2 ) )THEN LNCMP = .FALSE. RETURN ELSE IF( LN1( I ).EQ.'$' )THEN IF( I.LT.LEN1-1 )THEN IF( LN1( I+1 ).EQ.'$' )THEN I = I + 2 MATCH = .FALSE. 30 IF( ( LGE( LN2( J ), '0' ).AND.LLE( LN2( J ), '9' ) ) $ .AND.( J.LT.LEN2 ) )THEN J = J + 1 MATCH = .TRUE. GO TO 30 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 ELSE IF( LN2( J ).EQ.'$' )THEN IF( J.LT.LEN2-1 )THEN IF( LN2( J+1 ).EQ.'$' )THEN J = J + 2 MATCH = .FALSE. 40 IF( ( LGE( LN1( I ), '0' ).AND.LLE( LN1( I ), '9' ) ) $ .AND.( I.LT.LEN1 ) )THEN I = I + 1 MATCH = .TRUE. GO TO 40 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 END IF * LNCMP = .FALSE. RETURN * * End of LNCMP. * END SHAR_EOF fi # end of overwriting check if test -f 'csymm.f' then echo shar: will not over-write existing file "'csymm.f'" else cat << SHAR_EOF > 'csymm.f' SUBROUTINE CSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CSYMM performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is a symmetric matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the symmetric matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the symmetric matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * symmetric matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * symmetric matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - COMPLEX. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CCOPY * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ) ) * .. User specified parameters for CSYMM .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CSYMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL CGEMM ( 'N', 'N', M, N, 0, ZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by CCOPY is CB. * DO 30, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 20, J = JJ+1, II+ISEC-1 CALL CCOPY ( MIN( JSEC, J-JJ ), A( JJ, J ), 1, $ T1( J-II+1, JJ-II+1 ), RCB ) 20 CONTINUE 30 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL CGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 80, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 50, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 50 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by CCOPY is CB. * DO 70, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 60, J = II, JJ+JSEC-2 CALL CCOPY ( MIN( JSEC, JJ+JSEC-1-J ), $ A( MAX( JJ, J+1 ), J ), 1, $ T1( J-II+1, MAX( JJ-II+1, J-II+2 ) ), RCB ) 60 CONTINUE 70 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF 80 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 120, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 90, J = JJ, JJ+JSEC-1 CALL CCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 90 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by CCOPY is CB. * DO 110, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 100, I = II+1, JJ+JSEC-1 CALL CCOPY ( MIN( ISEC, I-II ), A( II, I ), 1, $ T1( I-JJ+1, II-JJ+1 ), RCB ) 100 CONTINUE 110 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF 120 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 160, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL CCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 130 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by CCOPY is CB. * DO 150, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 140, I = JJ, II+ISEC-2 CALL CCOPY ( MIN( ISEC, II+ISEC-1-I ), $ A( MAX( II, I+1 ), I ), 1, $ T1( I-JJ+1, MAX( II-JJ+1, I-JJ+2 ) ), RCB ) 140 CONTINUE 150 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, CGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL CGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 160 CONTINUE END IF END IF * RETURN * * End of CSYMM. * END SHAR_EOF fi # end of overwriting check if test -f 'csyr2k.f' then echo shar: will not over-write existing file "'csyr2k.f'" else cat << SHAR_EOF > 'csyr2k.f' SUBROUTINE CSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CSYR2K performs one of the symmetric rank 2k operations * * C := alpha*A*B' + alpha*B*A' + beta*C, * * or * * C := alpha*A'*B + alpha*B'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A and B are n by k matrices in the first case and k by n * matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + * beta*C. * * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'T' or 't', K specifies the number of rows of the * matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - COMPLEX . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, JJ, JX, JSEC LOGICAL UPPER, NOTR * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CAXPY, CSCAL * .. Parameters .. COMPLEX ONE, ZERO PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. User specified parameters for CSYR2K .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND. ( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CSYR2K', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL CSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL CSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Upper, Notr. * DO 70, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL CGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL CAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by CAXPY is CB. * DO 60, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 50, I = JJ, II+ISEC-1 CALL CAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 50 CONTINUE 60 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, BETA, $ C( 1, II ), LDC ) CALL CGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ONE, $ C( 1, II ), LDC ) END IF 70 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Upper, Trans. * DO 120, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A'*B, general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL CGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 80, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, C( II, I ), 1 ) 80 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 90, I = II, II+ISEC-1 CALL CAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 90 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by CAXPY is CB. * DO 110, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 100, I = JJ, II+ISEC-1 CALL CAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 100 CONTINUE 110 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, BETA, $ C( 1, II ), LDC ) CALL CGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( 1, II ), LDA, ONE, $ C( 1, II ), LDC ) END IF 120 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Lower, Notr. * DO 170, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL CGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 130, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 130 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 140, I = II, II+ISEC-1 CALL CAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 140 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by CAXPY is CB. * DO 160, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 150, I = II, JJ+JSEC-1 CALL CAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 150 CONTINUE 160 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL CGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ B( II+ISEC, 1 ), LDB, A( II, 1 ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 170 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Lower, Trans. * DO 220, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL CGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 180, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 180 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 190, I = II, II+ISEC-1 CALL CAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 190 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by CAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 CALL CAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 200 CONTINUE 210 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL CGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ B( 1, II+ISEC ), LDB, A( 1, II ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 220 CONTINUE END IF END IF * RETURN * * End of CSYR2K. * END SHAR_EOF fi # end of overwriting check if test -f 'csyrk.f' then echo shar: will not over-write existing file "'csyrk.f'" else cat << SHAR_EOF > 'csyrk.f' SUBROUTINE CSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * CSYRK performs one of the symmetric rank k operations * * C := alpha*A*A' + beta*C, * * or * * C := alpha*A'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A is an n by k matrix in the first case and a k by n matrix * in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. * * TRANS = 'T' or 't' C := alpha*A'*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'T' or 't', K specifies the number of rows of the * matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - COMPLEX . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK COMPLEX DELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME, CBIGP, CCLD EXTERNAL LSAME, CBIGP, CCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CGEMV, CCOPY, CSCAL * .. Parameters .. COMPLEX ONE, ZERO INTEGER CIP41, CIP42 PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ), $ ZERO = ( 0.0E+0, 0.0E+0 ), $ CIP41 = 41, CIP42 = 42 ) * .. User specified parameters for CSYRK .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) * .. Local Arrays .. COMPLEX T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( ( .NOT.NOTR ) ).AND.( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CSYRK ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL CSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL CSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Upper, Notr. * SMALLN = .NOT.CBIGP( CIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CBIGP( CIP42 , N, K ) DO 110, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 50, I = II, II+ISEC-1 DO 40, L = 1, K CALL CAXPY ( I-II+1, ALPHA*A( I, L ), $ A( II, L ), 1, C( II, I ), 1 ) 40 CONTINUE 50 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 60, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 60 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 70, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having upper * triangular storage format. * DO 90, I = II, II+ISEC-1 DO 80, L = 1, K CALL CAXPY ( I-II+1, ALPHA*A( I, L ), $ A( II, L ), 1, T2( 1, I-II+1 ), 1 ) 80 CONTINUE 90 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 100, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 100 CONTINUE END IF 110 CONTINUE ELSE DO 150, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 140, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 120, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 120 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 130, I = II, II+ISEC-1 CALL CGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 130 CONTINUE DELTA = ONE 140 CONTINUE 150 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Upper, Trans. * SMALLN = .NOT.CBIGP( CIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CBIGP( CIP42 , N, K ) DO 260, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 160, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, C( II, I ), 1 ) 160 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 180, I = II, II+ISEC-1 DO 170, L = 1, K CALL CAXPY ( I-II+1, ALPHA*A( L, I ), $ A( L, II ), LDA, C( II, I ), 1 ) 170 CONTINUE 180 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 190, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 190 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 200, I = II, II+ISEC-1 CALL CSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 200 CONTINUE END IF DO 240, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 210, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 210 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * upper triangular storage format. * DO 230, I = II, II+ISEC-1 DO 220, L = LL, LL+LSEC-1 CALL CAXPY ( I-II+1, $ ALPHA*T3( I-II+1, L-LL+1 ), $ T3( 1, L-LL+1 ), 1, $ T2( 1, I-II+1 ), 1 ) 220 CONTINUE 230 CONTINUE 240 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 250, I = II, II+ISEC-1 CALL CCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 250 CONTINUE END IF 260 CONTINUE ELSE CLDA = CCLD( LDA ) DO 310, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL CGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 300, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 270, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 280 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 290, I = II, II+ISEC-1 CALL CGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 290 CONTINUE DELTA = ONE 300 CONTINUE 310 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Lower, Notr. * SMALLN = .NOT.CBIGP( CIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CBIGP( CIP42 , N, K ) DO 400, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 320, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 320 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 340, I = II, II+ISEC-1 DO 330, L = 1, K CALL CAXPY ( II+ISEC-I, ALPHA*A( I, L ), $ A( I, L ), 1, C( I, I ), 1 ) 330 CONTINUE 340 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 350, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 350 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 360, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 360 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having lower * triangular storage format. * DO 380, I = II, II+ISEC-1 DO 370, L = 1, K CALL CAXPY ( II+ISEC-I, ALPHA*A( I, L ), $ A( I, L ), 1, T2( I-II+1, I-II+1 ), 1 ) 370 CONTINUE 380 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 390, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 400 CONTINUE ELSE DO 440, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 430, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 410, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 410 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 420, I = II, II+ISEC-1 CALL CGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 420 CONTINUE DELTA = ONE 430 CONTINUE * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 440 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Lower, Trans. * SMALLN = .NOT.CBIGP( CIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.CBIGP( CIP42 , N, K ) DO 550, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 450, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 450 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 470, I = II, II+ISEC-1 DO 460, L = 1, K CALL CAXPY ( II+ISEC-I, ALPHA*A( L, I ), $ A( L, I ), LDA, C( I, I ), 1 ) 460 CONTINUE 470 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 480, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 480 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 490, I = II, II+ISEC-1 CALL CSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 490 CONTINUE END IF DO 530, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 500, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 500 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * lower triangular storage format. * DO 520, I = II, II+ISEC-1 DO 510, L = LL, LL+LSEC-1 CALL CAXPY ( II+ISEC-I, $ ALPHA*T3( I-II+1, L-LL+1 ), $ T3( I-II+1, L-LL+1 ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 510 CONTINUE 520 CONTINUE 530 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 540, I = II, II+ISEC-1 CALL CCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 540 CONTINUE END IF * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 550 CONTINUE ELSE CLDA = CCLD( LDA ) DO 600, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 590, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 560, I = II, II+ISEC-1 CALL CCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 560 CONTINUE ELSE DO 570, L = LL, LL+LSEC-1 CALL CCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 570 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 580, I = II, II+ISEC-1 CALL CGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 580 CONTINUE DELTA = ONE 590 CONTINUE * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL CGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 600 CONTINUE END IF END IF END IF * RETURN * * End of CSYRK. * END SHAR_EOF fi # end of overwriting check if test -f 'ctrmm.f' then echo shar: will not over-write existing file "'ctrmm.f'" else cat << SHAR_EOF > 'ctrmm.f' SUBROUTINE CTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC COMPLEX ALPHA * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * CTRMM performs one of the matrix-matrix operations * * C := alpha*op( A )*C, or C := alpha*C*op( A ) * * where alpha is a scalar, C is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies C from * the left or right as follows: * * SIDE = 'L' or 'l' C := alpha*op( A )*C. * * SIDE = 'R' or 'r' C := alpha*C*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, and on exit is overwritten by the * transformed matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOCONJ, NOUNIT, $ CLDC, SMALLN, TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC COMPLEX GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD, CONJG * .. External Functions .. LOGICAL LSAME, CBIGP, CCLD EXTERNAL LSAME, CBIGP, CCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CGEMV, CTRMV, CCOPY * .. Parameters .. COMPLEX ZERO, ONE INTEGER CIP81, CIP82, CIP83 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ), $ CIP81 = 81, CIP82 = 82, CIP83 = 83 ) * .. User specified parameters for CTRMM .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) COMPLEX T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( ( .NOT.NOTR ).AND.( .NOT.NOCONJ ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CTRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL CGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*C. Left, Upper, No transpose. * SMALLN = .NOT.CBIGP( CIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.CBIGP( CIP82, M, N ) DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 10, J = 1, N CALL CTRMV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * C := T3*C, triangular matrix multiply involving * a upper triangular diagonal block of A stored * in T3. * DO 30, J = 1, N CALL CTRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE DELTA = ALPHA CLDC = CCLD( LDC ) DO 110, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in CGEMV that appears if the second * dimension (tsec) is zero. * DO 80, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 110 CONTINUE END IF ELSE * * Form C := alpha*A'*C or C := alpha*conjg( A' )*C. * Left, Upper, Transpose or Conjugated transpose * SMALLN = .NOT.CBIGP( CIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.CBIGP( CIP82, M, N ) DO 150, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( TRANSA, 'N', ISEC, N, 0, ZERO, A, $ LDA, C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C or C := conjg( A' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A. * DO 120, J = 1, N CALL CTRMV ( 'U', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 130 CONTINUE * * C := T3'*C or C := conjg( T3' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A stored in T3. * DO 140, J = 1, N CALL CTRMV ( 'U', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL CGEMM ( TRANSA, 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 150 CONTINUE ELSE DELTA = ALPHA CLDC = CCLD( LDC ) DO 240, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * upper triangular diagonal block of A is copied to * the upper triangular part of T2. * IF( NOCONJ )THEN DO 160, J = II+OFFD, II+ISEC-1 CALL CCOPY ( J-II+1-OFFD, A( II, J ), 1, $ T2( 1, J-II+1 ), 1 ) 160 CONTINUE ELSE DO 180, J = II+OFFD, II+ISEC-1 DO 170, I = II, J-OFFD T2( I-II+1, J-II+1 ) = CONJG( A( I, J ) ) 170 CONTINUE 180 CONTINUE END IF DO 230, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 190, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 190 CONTINUE ELSE DO 200, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 200 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 210, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 210 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 220, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 220 CONTINUE 230 CONTINUE * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL CGEMM ( TRANSA, 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 240 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*C. Left, Lower, No transpose. * SMALLN = .NOT.CBIGP( CIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.CBIGP( CIP82, M, N ) DO 280, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 250, J = 1, N CALL CTRMV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 250 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. * DO 260, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 260 CONTINUE * * C := T3*C, triangular matrix multiply involving * a lower triangular diagonal block of A stored * in T3. * DO 270, J = 1, N CALL CTRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 270 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 280 CONTINUE ELSE DELTA = ALPHA CLDC = CCLD( LDC ) DO 350, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 290, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 290 CONTINUE DO 340, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 300, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 300 CONTINUE ELSE DO 310, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in CGEMV that appears if the second * dimension (tsec) is zero. * DO 320, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 320 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 330, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 330 CONTINUE 340 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL CGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 350 CONTINUE END IF ELSE * * Form C := alpha*A'*C or C := alpha*conjg( A' )*C. * Left, Lower, Transpose or Conjugated transpose * SMALLN = .NOT.CBIGP( CIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.CBIGP( CIP82, M, N ) DO 390, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( TRANSA, 'N', ISEC, N, 0, ZERO, A, $ LDA, C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C or C := conjg( A' )*C, triangular * matrix multiply involving a lower triangular * diagonal block of A. * DO 360, J = 1, N CALL CTRMV ( 'L', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 360 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to part of T3. * DO 370, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 370 CONTINUE * * C := T3'*C or C := conjg( T3' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A stored in T3. * DO 380, J = 1, N CALL CTRMV ( 'L', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 380 CONTINUE END IF * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 390 CONTINUE ELSE DELTA = ALPHA CLDC = CCLD( LDC ) DO 480, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A or T2 := conjg( A ), a unit or non-unit * lower triangular diagonal block of A is copied to * the lower triangular part of T2. * IF( NOCONJ )THEN DO 400, J = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-II+1+OFFD, J-II+1 ), 1 ) 400 CONTINUE ELSE DO 420, J = II, II+ISEC-1-OFFD DO 410, I = J+OFFD, II+ISEC-1 T2( I-II+1, J-II+1 ) = CONJG( A( I, J ) ) 410 CONTINUE 420 CONTINUE END IF DO 470, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 430, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 430 CONTINUE ELSE DO 440, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 440 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 450, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 450 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 460, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL CGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 480 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*C*A. Right, Upper, No transpose. * TINYM = .NOT.CBIGP( CIP83, M, N ) IF( TINYM )THEN DO 500, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 490, I = 1, M CALL CTRMV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 500 CONTINUE ELSE DELTA = ALPHA DO 540, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) DO 530, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 510, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 510 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 520, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, C( II, J ), 1 ) 520 CONTINUE 530 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 540 CONTINUE END IF ELSE * * Form C := alpha*C*A' or C := alpha*C*conjg( A' ). * Right, Upper, Transpose or Conjugated transpose. * TINYM = .NOT.CBIGP( CIP83, M, N ) IF( TINYM )THEN DO 570, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', TRANSA, M, JSEC, 0, ZERO, C, $ LDC, A, LDA, ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T3. * DO 550, J = JJ+OFFD, JJ+JSEC-1 CALL CCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T3( J-JJ+1, 1 ), RCB ) 550 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a upper triangular * diagonal block of T3. * DO 560, I = 1, M CALL CTRMV ( 'L', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 560 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 570 CONTINUE ELSE DELTA = ALPHA DO 640, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit upper triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 580, J = JJ+OFFD, JJ+JSEC-1 CALL CCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 580 CONTINUE ELSE DO 600, J = JJ+OFFD, JJ+JSEC-1 DO 590, I = JJ, J-OFFD T2( J-JJ+1, I-JJ+1 ) = CONJG( A( I, J ) ) 590 CONTINUE 600 CONTINUE END IF DO 630, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 610, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 610 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 620, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 620 CONTINUE 630 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 640 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*C*A. Right, Lower, No transpose. * TINYM = .NOT.CBIGP( CIP83, M, N ) IF( TINYM )THEN DO 660, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * lower triangular diagonal block of A. * DO 650, I = 1, M CALL CTRMV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 650 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 660 CONTINUE ELSE DELTA = ALPHA DO 700, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 DO 690, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 670, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 670 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 680, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, C( II, J ), 1 ) 680 CONTINUE 690 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 700 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Lower, Transpose. * TINYM = .NOT.CBIGP( CIP83, M, N ) IF( TINYM )THEN DO 730, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL CGEMM ( 'N', TRANSA, M, JSEC, 0, ZERO, C, $ LDC, A, LDA, ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T3. * DO 710, J = JJ, JJ+JSEC-1-OFFD CALL CCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T3( J-JJ+1, J-JJ+1+OFFD ), RCB ) 710 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a lower triangular * diagonal block of T3. * DO 720, I = 1, M CALL CTRMV ( 'U', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 720 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a lower triangular * diagonal block of T3. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', TRANSA, M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 730 CONTINUE ELSE DELTA = ALPHA DO 800, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit lower triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 740, J = JJ, JJ+JSEC-1-OFFD CALL CCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 740 CONTINUE ELSE DO 760, J = JJ, JJ+JSEC-1-OFFD DO 750, I = J+OFFD, JJ+JSEC-1 T2( J-JJ+1, I-JJ+1 ) = CONJG( A( I, J ) ) 750 CONTINUE 760 CONTINUE END IF DO 790, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 770, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 770 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in CGEMV that appears if the * second dimension (tsec) is zero. * DO 780, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 780 CONTINUE 790 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL CGEMM ( 'N', TRANSA, M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 800 CONTINUE END IF END IF END IF END IF * RETURN * * End of CTRMM. * END SHAR_EOF fi # end of overwriting check if test -f 'ctrsm.f' then echo shar: will not over-write existing file "'ctrsm.f'" else cat << SHAR_EOF > 'ctrsm.f' SUBROUTINE CTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC COMPLEX ALPHA * .. Array Arguments .. COMPLEX A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * CTRSM solves one of the matrix equations * * op( A )*X = alpha*C, or X*op( A ) = alpha*C, * * where alpha is a scalar, X and C are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * The matrix X is overwritten on C. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*C. * * SIDE = 'R' or 'r' X*op( A ) = alpha*C. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the right-hand side matrix C, and on exit is * overwritten by the solution matrix X. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOCONJ, NOUNIT, $ CLDC, SMALLN, TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC COMPLEX GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD, CONJG * .. External Functions .. LOGICAL LSAME, CBIGP, CCLD EXTERNAL LSAME, CBIGP, CCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL CGEMM, CGEMV, CTRSV, CCOPY * .. Parameters .. COMPLEX ZERO, ONE INTEGER CIP91, CIP92, CIP93 PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ), $ ONE = ( 1.0E+0, 0.0E+0 ), $ CIP91 = 91, CIP92 = 92, CIP93 = 93 ) * .. User specified parameters for CTRSM .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) COMPLEX T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( ( .NOT.NOTR ).AND.( .NOT.NOCONJ ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CTRSM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL CGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Upper, No transpose. * SMALLN = .NOT.CBIGP( CIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.CBIGP( CIP92, M, N ) DO 40, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a upper triangular diagonal block of A. The * block of X is overwritten on C. * DO 10, J = 1, N CALL CTRSV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * Solve T3*X = C, triangular system solve * involving a upper triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 30, J = 1, N CALL CTRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF 40 CONTINUE ELSE DELTA = ONE CLDC = CCLD( LDC ) DO 110, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 80, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = II+ISEC-1-I TIJ = 1 IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE 110 CONTINUE END IF ELSE * * Solve A'*X = alpha*C or conjg( A' )*X = alpha*C. * Left, Upper, Transpose or Conjugated transpose. * SMALLN = .NOT.CBIGP( CIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.CBIGP( CIP92, M, N ) DO 150, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL CGEMM ( TRANSA, 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C or conjg( A' )*X = C, * triangular system solve involving a upper * triangular diagonal block of A. The block of X * is overwritten on C. * DO 120, J = 1, N CALL CTRSV ( 'U', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A, a unit or non-unit triangular diagonal * block of A is copied to T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL CCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 130 CONTINUE * * Solve T3'*X = C or conjg( T3' )*X = C, * triangular system solve involving a upper * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 140, J = 1, N CALL CTRSV ( 'U', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF 150 CONTINUE ELSE DELTA = ONE CLDC = CCLD( LDC ) DO 240, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL CGEMM ( TRANSA, 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * upper triangular diagonal block of A is copied to * the upper triangular part of T2. * IF( NOCONJ )THEN DO 160, J = II+OFFD, II+ISEC-1 CALL CCOPY ( J-II+1-OFFD, A( II, J ), 1, $ T2( 1, J-II+1 ), 1 ) 160 CONTINUE ELSE DO 180, J = II+OFFD, II+ISEC-1 DO 170, I = II, J-OFFD T2( I-II+1, J-II+1 ) = CONJG( A( I, J ) ) 170 CONTINUE 180 CONTINUE END IF DO 230, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 190, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 190 CONTINUE ELSE DO 200, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 200 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 210, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 210 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 220, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 220 CONTINUE 230 CONTINUE 240 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Lower, No transpose. * SMALLN = .NOT.CBIGP( CIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.CBIGP( CIP92, M, N ) DO 280, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL CGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a lower triangular diagonal block of A. The * block of X is overwritten on C. * DO 250, J = 1, N CALL CTRSV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 250 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. The block of X is * overwritten on C. * DO 260, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 260 CONTINUE * * Solve T3*X = C, triangular system solve * involving a lower triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 270, J = 1, N CALL CTRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 270 CONTINUE END IF 280 CONTINUE ELSE DELTA = ONE CLDC = CCLD( LDC ) DO 350, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL CGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 290, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 290 CONTINUE DO 340, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 300, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 300 CONTINUE ELSE DO 310, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 320, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 320 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 330, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 330 CONTINUE 340 CONTINUE 350 CONTINUE END IF ELSE * * Solve A'*X = alpha*C or conjg( A' )*X = alpha*C. * Left, Lower, Transpose or Conjugated transpose. * SMALLN = .NOT.CBIGP( CIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.CBIGP( CIP92, M, N ) DO 390, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C or conjg( A' )*X = C, * triangular system solve involving a lower * triangular diagonal block of A. The block of X * is overwritten on C. * DO 360, J = 1, N CALL CTRSV ( 'L', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 360 CONTINUE ELSE * * T3 := A, a unit or non-unit triangular diagonal * block of A is copied to T3. * DO 370, I = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 370 CONTINUE * * Solve T3'*X = C or conjg( T3' )*X = C, * triangular system solve involving a lower * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 380, J = 1, N CALL CTRSV ( 'L', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 380 CONTINUE END IF 390 CONTINUE ELSE DELTA = ONE CLDC = CCLD( LDC ) DO 480, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * lower triangular diagonal block of A is copied to * the lower triangular part of T2. * IF( NOCONJ )THEN DO 400, J = II, II+ISEC-1-OFFD CALL CCOPY ( II+ISEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-II+1+OFFD, J-II+1 ), 1 ) 400 CONTINUE ELSE DO 420, J = II, II+ISEC-1-OFFD DO 410, I = J+OFFD, II+ISEC-1 T2( I-II+1, J-II+1 ) = CONJG( A( I, J ) ) 410 CONTINUE 420 CONTINUE END IF DO 470, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 430, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 430 CONTINUE ELSE DO 440, I = II, II+ISEC-1 CALL CCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 440 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 450, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 450 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 460, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE 480 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Upper, No transpose. * TINYM = .NOT.CBIGP( CIP93, M, N ) IF( TINYM )THEN DO 500, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a upper triangular diagonal block of A. The block * of X is overwritten on C. * DO 490, I = 1, M CALL CTRSV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE 500 CONTINUE ELSE DELTA = ONE DO 550, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL CGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 540, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 510, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 510 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 520, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 520 CONTINUE * * C := T1, T1 is copied back to C. * DO 530, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 530 CONTINUE 540 CONTINUE 550 CONTINUE END IF ELSE * * Solve X*A' = alpha*C or X*conjg( A' ) = alpha*C. * Right, Upper, Transpose or Conjugated transpose. * TINYM = .NOT.CBIGP( CIP93, M, N ) IF( TINYM )THEN DO 580, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to T3. * DO 560, J = JJ+OFFD, JJ+JSEC-1 CALL CCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T3( J-JJ+1, 1 ), RCB ) 560 CONTINUE * * Solve X*T3' = C or X*conjg( T3' ) = C, triangular * system solve involving the transpose of a upper * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 570, I = 1, M CALL CTRSV ( 'L', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 570 CONTINUE 580 CONTINUE ELSE DELTA = ONE DO 660, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit upper triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 590, J = JJ+OFFD, JJ+JSEC-1 CALL CCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 590 CONTINUE ELSE DO 610, J = JJ+OFFD, JJ+JSEC-1 DO 600, I = JJ, J-OFFD T2( J-JJ+1, I-JJ+1 ) = CONJG( A( I, J ) ) 600 CONTINUE 610 CONTINUE END IF DO 650, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 620, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 620 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 630, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 630 CONTINUE * * C := T1, T1 is copied back to C. * DO 640, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 640 CONTINUE 650 CONTINUE 660 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Lower, No transpose. * TINYM = .NOT.CBIGP( CIP93, M, N ) IF( TINYM )THEN DO 680, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a lower triangular diagonal block of A. The block * of X is overwritten on C. * DO 670, I = 1, M CALL CTRSV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 670 CONTINUE 680 CONTINUE ELSE DELTA = ONE DO 730, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL CGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 720, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 690, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 690 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 700, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 700 CONTINUE * * C := T1, T1 is copied back to C. * DO 710, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 710 CONTINUE 720 CONTINUE 730 CONTINUE END IF ELSE * * Solve X*A' = alpha*C or X*conjg( A' ) = alpha*C. * Right, Lower, Transpose or Conjugated transpose. * TINYM = .NOT.CBIGP( CIP93, M, N ) IF( TINYM )THEN DO 760, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL CGEMM ( 'N', TRANSA, M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to T3. * DO 740, J = JJ, JJ+JSEC-1-OFFD CALL CCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T3( J-JJ+1, J-JJ+1+OFFD ), RCB ) 740 CONTINUE * * Solve X*T3' = C or X*conjg( T3' ) = C, triangular * system solve involving the transpose of a lower * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 750, I = 1, M CALL CTRSV ( 'U', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 750 CONTINUE 760 CONTINUE ELSE DELTA = ONE DO 840, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL CGEMM ( 'N', TRANSA, M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit lower triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 770, J = JJ, JJ+JSEC-1-OFFD CALL CCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 770 CONTINUE ELSE DO 790, J = JJ, JJ+JSEC-1-OFFD DO 780, I = J+OFFD, JJ+JSEC-1 T2( J-JJ+1, I-JJ+1 ) = CONJG( A( I, J ) ) 780 CONTINUE 790 CONTINUE END IF DO 830, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 800, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 800 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in CGEMV that * appears if the second dimension (tsec) is zero. * DO 810, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL CGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 810 CONTINUE * * C := T1, T1 is copied back to C. * DO 820, J = JJ, JJ+JSEC-1 CALL CCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 820 CONTINUE 830 CONTINUE 840 CONTINUE END IF END IF END IF END IF * RETURN * * End of CTRSM. * END SHAR_EOF fi # end of overwriting check if test -f 'eoln.f' then echo shar: will not over-write existing file "'eoln.f'" else cat << SHAR_EOF > 'eoln.f' INTEGER FUNCTION EOLN( LN, LLN ) * .. Scalar Arguments .. INTEGER LLN * .. Array Arguments .. CHARACTER LN( LLN ) * * Return the index of the last non-blank character in the last word * (token) of LN. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER IE * .. * .. Executable Statements .. * * Find the end of the last word (token) of LN. * IE = LLN 10 IF( ( LN( IE ).EQ.' ' ).AND.( IE.GE.1 ) )THEN IE = IE - 1 GO TO 10 END IF EOLN = IE * RETURN * * End of EOLN. * END SHAR_EOF fi # end of overwriting check if test -f 'getwrd.f' then echo shar: will not over-write existing file "'getwrd.f'" else cat << SHAR_EOF > 'getwrd.f' LOGICAL FUNCTION GETWRD( LN, LLN, IB, IE ) * .. Scalar Arguments .. INTEGER LLN, IB, IE * .. Array Arguments .. CHARACTER LN( LLN ) * * Read the first non-blank word from the character string LN. Set * the indices IB and IE to the beginning and end of the word, * respectively. Return .TRUE. if a word was found and .FALSE. if no * word was found. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * .. * .. Executable Statements .. * * Find the beginning of the word. * IB = 1 10 IF( ( LN( IB ).EQ.' ' ).AND.( IB.LT.LLN ) )THEN IB = IB + 1 GO TO 10 END IF * * Find the end of the word. * IE = IB 20 IF( IE.LT.LLN )THEN IF( LN( IE+1 ).NE.' ' )THEN IE = IE + 1 GO TO 20 END IF END IF * * Check if any word was found. * IF( LN( IB ).NE.' ' )THEN GETWRD = .TRUE. ELSE GETWRD = .FALSE. END IF * RETURN * * End of GETWRD. * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'DGBL3B' then mkdir 'DGBL3B' fi cd 'DGBL3B' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # DGBFLG : the GEMM-based level 3 BLAS routines # DAXFLG : GEMM-based specific auxiliary routines # AXOPT : other auxiliary routines # DGBFLG = $(GBOPT) DAXFLG = $(GBOPT) AXFLG = $(AXOPT) # ### GEMM-based Level 3 BLAS ############################################## AUXS = lsame.f xerbla.f AUX = lsame.o xerbla.o DGBS = dsymm.f dsyrk.f dsyr2k.f dtrmm.f dtrsm.f DGB = dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o DAUXS = dbigp.f dcld.f DAUX = dbigp.o dcld.o DGPMS = dsgpm.f getwrd.f eoln.f DGPM = dsgpm.o getwrd.o eoln.o ######################################################################## all: $(GBL3B) dsgpm $(GBL3B): $(DGB) $(DAUX) $(AUX) $(ARCH) $(ARCHFLAGS) $(GBL3B) $(DGB) $(DAUX) $(AUX) $(RANLIB) $(GBL3B) dsgpm: $(DGPM) $(LOADER) $(LOADOPT) -o dsgpm $(DGPM) $(DGB): $(DGBS) $(FORTRAN) -c $(DGBFLG) $(DGBS) $(DAUX): $(DAUXS) $(FORTRAN) -c $(DAXFLG) $(DAUXS) $(AUX): $(AUXS) $(FORTRAN) -c $(AXFLG) $(AUXS) $(DGPM): $(DGPMS) $(FORTRAN) -c $(AXFLG) $(DGPMS) clean: rm -f *.o dsgpm SHAR_EOF fi # end of overwriting check if test -f 'dbigp.f' then echo shar: will not over-write existing file "'dbigp.f'" else cat << SHAR_EOF > 'dbigp.f' LOGICAL FUNCTION DBIGP( IP, DIM1, DIM2 ) * .. Scalar Arguments .. INTEGER IP, DIM1, DIM2 * .. * * Purpose * ======= * * DBIGP determines which of two alternative code sections in a GEMM- * Based Level 3 BLAS routine that will be the fastest for a particular * problem. If the problem is considered large enough DBIGP returns * .TRUE., otherwise .FALSE. is returned. The input parameter IP * specifies the calling routine and a break point for alternative code * sections. The input parameters DIM1 and DIM2 are matrix dimensions. * The returned value is a function of the input parameters and the * performance characteristics of the two alternative code sections. * * In this simple implementation, the returned values are determined by * looking at only one of the two dimensions DIM1 and DIM2. It may be * rewarding to rewrite the logical expressions in DBIGP so that both * dimensions are involved. The returned values should effectively * reflect the performance characteristics of the underlying BLAS * routines. * * * Input * ===== * * IP - INTEGER * On entry, IP specifies which routine and which alternative * code sections that the decision is intended for. * Unchanged on exit. * * DIM1 - INTEGER. * On entry, DIM1 specifies the first dimension in the calling * sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * DIM2 - INTEGER. * On entry, DIM2 specifies the second dimension in the * calling sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. User specified parameters for DBIGP .. INTEGER DIP41, DIP42, DIP81, DIP82, DIP83, $ DIP91, DIP92, DIP93 PARAMETER ( DIP41 = 4, DIP42 = 3, $ DIP81 = 4, DIP82 = 3, DIP83 = 4, $ DIP91 = 4, DIP92 = 3, DIP93 = 4 ) * .. * .. Executable Statements .. IF( IP.EQ.41 )THEN DBIGP = DIM1.GE.DIP41 ELSE IF( IP.EQ.42 )THEN DBIGP = DIM2.GE.DIP42 ELSE IF( IP.EQ.81 )THEN DBIGP = DIM2.GE.DIP81 ELSE IF( IP.EQ.82 )THEN DBIGP = DIM2.GE.DIP82 ELSE IF( IP.EQ.83 )THEN DBIGP = DIM1.GE.DIP83 ELSE IF( IP.EQ.91 )THEN DBIGP = DIM2.GE.DIP91 ELSE IF( IP.EQ.92 )THEN DBIGP = DIM2.GE.DIP92 ELSE IF( IP.EQ.93 )THEN DBIGP = DIM1.GE.DIP93 ELSE DBIGP = .FALSE. END IF * RETURN * * End of DBIGP. * END SHAR_EOF fi # end of overwriting check if test -f 'dcld.f' then echo shar: will not over-write existing file "'dcld.f'" else cat << SHAR_EOF > 'dcld.f' LOGICAL FUNCTION DCLD( LD ) * .. Scalar Arguments .. INTEGER LD * .. * * Purpose * ======= * * The size of the leading dimension of a two-dimensional array may * cause severe problems. Often when an array with a 'critical' leading * dimension is referenced, the execution time becomes significantly * longer than expected. This is caused by shortcomings of the memory * system. * * The function DCLD returns .TRUE. if the leading dimension LD is * critical and .FALSE. if it is not critical. In this implementation * DCLD is designed to detect critical leading dimensions in an * environment with a multi-way associative cache. Parameters defining * cache characteristics are adjustable to match different machines. * It may be rewarding to rewrite DCLD for a machine with a different * cache policy. * * The cache lines in a multi-way associative cache are divided among a * number of partitions, each containing the same number of lines. Each * address of main memory is mapped into a particular partition. The * number of lines in a partition equals the associativity. For example, * in a four way associative cache, each partition contain four cache * lines. * * Data are transferred between the cache and main memory according to * an associative mapping scheme. A transfer of a data word from main * memory to cache is accomplished as follows. A unit of data * (data line) in main memory, with the size of a cache line, and * containing several contiguous data words including the referenced * one, is mapped (copied) to a certain partition in the cache memory. * The partition is determined by the location of the element in the * main memory and the associative mapping scheme. A replacement * algorithm makes room for the data line in one of the cache lines in * the selected partition. For example, an LRU-based (Least Recently * Used) replacement algorithm places the data line in the least * recently 'touched' cache line in the selected partition. * * * Input * ===== * * LD - On entry, LD specifies the leading dimension of a * 2-dimensional array. Unchanged on exit. * * * User specified parameters for DCLD * ================================ * * LNSZ - Size of a cache line in number of bytes. * * NPRT - Number of partitions in the cache memory. * * PRTSZ - The number of cache lines in a partition that can be used * exclusively to hold a local array containing a matrix block * during the execution of a GEMM-Based Level 3 BLAS routine. * The remaining cache lines may be occupied by scalars, * vectors and possibly program code depending on the system. * * LOLIM - Leading dimensions smaller than or equal to LOLIM are not * considered critical. * * DP - Number of bytes in a double-precision word. * * * Local Variables and Parameters * ============================== * * ONEWAY - The maximum number of double precision words that can be * stored in the cache memory if only a single cache line in * each partition may be used. * * UPDIF - The difference between the multiple of LD that is nearest * ONEWAY, or nearest a multiple of ONEWAY, and the nearest * multiple of ONEWAY that is larger than LD. In number of * double precision words. * * MXDIF - If both UPDIF and LD - UPDIF are less than MXDIF, and LD * is greater than LOLIM, then the leading dimension is * considered critical. Otherwise, the leading dimension is * considered not critical. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Variables .. INTEGER UPDIF * .. Intrinsic Functions .. INTRINSIC MIN, MOD * .. User specified parameters for DCLD .. INTEGER LOLIM, LNSZ, NPRT, PRTSZ, DP PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, DP = 8 ) * .. Parameters .. INTEGER ONEWAY, MXDIF PARAMETER ( ONEWAY = ( LNSZ*NPRT )/DP, $ MXDIF = LNSZ/( DP*PRTSZ ) ) * .. * .. Executable Statements .. * IF( LD.LE.LOLIM )THEN DCLD = .FALSE. ELSE UPDIF = MOD( ( LD/ONEWAY )*ONEWAY+ONEWAY, LD ) DCLD = MIN( UPDIF, LD-UPDIF ).LE.MXDIF END IF * RETURN * * End of DCLD. * END SHAR_EOF fi # end of overwriting check if test -f 'dgpm.in' then echo shar: will not over-write existing file "'dgpm.in'" else cat << SHAR_EOF > 'dgpm.in' * * Example of an input file for the program DSGPM containing user * specified parameters. * * The enclosed program DSGPM re-writes GEMM-Based Level 3 BLAS source * files replacing lines containing old PARAMETER statements for user * specified parameters, with lines containing new PARAMETER statements * given in an input file. The user can conveniently assign new values * to the PARAMETER statements in the input file, and then run DSGPM to * distribute these values to the GEMM-based routines. An input file * consists of three different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file. Read the file * INSTALL for further instructions on how to use this file. * dsymm.f PARAMETER ( RCB = 128, CB = 64 ) dsyr2k.f PARAMETER ( RCB = 128, CB = 64 ) dsyrk.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) dtrmm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) dtrsm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) dbigp.f PARAMETER ( DIP41 = 4, DIP42 = 3, $ DIP81 = 4, DIP82 = 3, DIP83 = 4, $ DIP91 = 4, DIP92 = 3, DIP93 = 4 ) dcld.f PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, DP = 8 ) SHAR_EOF fi # end of overwriting check if test -f 'dsgpm.f' then echo shar: will not over-write existing file "'dsgpm.f'" else cat << SHAR_EOF > 'dsgpm.f' PROGRAM DSGPM * * DSGPM re-writes GEMM-Based Level 3 BLAS source files replacing lines * containing old PARAMETER statements for user specified parameters, * with lines containing new PARAMETER statements given in an input * file. The user can conveniently assign new values to the PARAMETER * statements in the input file, and then run DSGPM to distribute these * values to the GEMM-based routines. An input file consists of three * different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file (see the input file * 'dgpm.in'). Read the file INSTALL for further instructions. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, IB, IE, JB, JE, KB, KE, NAM, NXTLN LOGICAL PMEOF * .. External Functions .. LOGICAL LNCMP, GETWRD INTEGER EOLN EXTERNAL LNCMP, GETWRD, EOLN * .. Parameters .. INTEGER NPM, NGB, NTMP, NERR PARAMETER ( NPM = 5, NERR = 6, NGB = 10, NTMP = 12 ) INTEGER NLNS, LLN PARAMETER ( NLNS = 10, LLN = 256 ) CHARACTER TMPNAM*( LLN ) PARAMETER ( TMPNAM = 'tmpgb.tmp' ) * .. Local Arrays .. CHARACTER PMLN*( LLN ), GBLN*( LLN ), GBNAM*( LLN ), $ STRS( NLNS, 2 )*( LLN ) CHARACTER PMLNA( LLN ), GBLNA( LLN ), GBNAMA( LLN ), $ STRSA( LLN, NLNS, 2 ) EQUIVALENCE ( PMLN, PMLNA ), ( GBLN, GBLNA ), $ ( GBNAM, GBNAMA ), ( STRS, STRSA ) * .. Data statements .. DATA STRS/ $'dsymm.f' ,'dsyrk.f' ,'dsyr2k.f' ,'dtrmm.f' ,'dtrsm.f' , $'dbigp.f' ,' ',' ','dcld.f' ,' ', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( DIP41 = $$ , DIP42 = $$ ,', $'$ DIP81 = $$ , DIP82 = $$ , DIP83 = $$ ,', $'$ DIP91 = $$ , DIP92 = $$ , DIP93 = $$ )', $'PARAMETER ( LNSZ = $$ , NPRT = $$ , PRTSZ = $$ ,', $'$ LOLIM = $$ , DP = $$ )' / * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. * 10 READ( NPM, FMT = 9000, END = 110 ) GBNAM IF( .NOT.GETWRD( GBNAMA, LLN, IB, IE ).OR. $ ( GBNAM( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * Check if the first word on the line is the name of a file that is * due to be changed. * 20 NAM = -1 PMEOF = .FALSE. DO 30, I = 1, NLNS IF( GBNAM( IB:IE ).EQ.STRS( I, 1 ) )THEN NAM = I END IF 30 CONTINUE IF( NAM.EQ.-1 )THEN WRITE( NERR, FMT = * )'Unknown routine name: ', GBNAM( IB:IE ) STOP END IF * * Read the next non-blank/non-comment line from the input parameter * file. * 40 READ( NPM, FMT = 9000, END = 110 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 40 END IF * * Copy each line of the GEMM-Based file, except for the lines that * are due to be changed, to the temporary file TMPNAM. Copy the * lines that should be changed from the input parameter file. Check * that the lines in the parameter file are correct compared to STRS. * NXTLN = NAM IF( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN OPEN( NGB, FILE = GBNAM( IB:IE ), STATUS = 'OLD' ) OPEN( NTMP, FILE = TMPNAM, STATUS = 'NEW' ) 50 READ( NGB, FMT = 9000, END = 80 ) GBLN IF( LNCMP( GBLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN WRITE( NTMP, FMT = 9010 ) PMLN( 1:EOLN( PMLNA, LLN ) ) 60 READ( NPM, FMT = 9000, END = 70 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 60 END IF IF( .NOT.GETWRD( STRSA( 1, NXTLN+1, 1 ), LLN, KB, KE ).AND. $ ( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN+1, 2 ), LLN ) ) $ )THEN NXTLN = NXTLN + 1 END IF ELSE WRITE( NTMP, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) END IF GO TO 50 70 PMEOF = .TRUE. GO TO 50 80 CLOSE( NGB, STATUS = 'DELETE' ) CLOSE( NTMP, STATUS = 'KEEP' ) ELSE WRITE( NERR, FMT = * )'Error in parameter file: ' WRITE( NERR, FMT = * ) PMLN STOP END IF * * Write back the temporary file TMPNAM to the GEMM-Based file and * remove the temporary file. * OPEN( NTMP, FILE = TMPNAM, STATUS = 'OLD' ) OPEN( NGB, FILE = GBNAM( IB:IE ), STATUS = 'NEW' ) 90 READ( NTMP, FMT = 9000, END = 100 ) GBLN WRITE( NGB, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) GO TO 90 100 CONTINUE CLOSE( NTMP, STATUS = 'DELETE' ) CLOSE( NGB, STATUS = 'KEEP' ) GBNAM = PMLN IB = JB IE = JE * IF( .NOT.PMEOF )THEN GO TO 20 END IF 110 CONTINUE * STOP * 9000 FORMAT( A ) 9010 FORMAT( A ) * * End of DSGPM. * END LOGICAL FUNCTION LNCMP( LN1, LEN1, LN2, LEN2 ) * .. Scalar Arguments .. INTEGER LEN1, LEN2 * .. Array Arguments .. CHARACTER LN1( LEN1 ), LN2( LEN2 ) * * Compare the character strings LN1 and LN2. Return .TRUE. if the * strings are identical except from wild cards ($$) corresponding * to positive integers and except from a different number of * consecutive blanks between tokens. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER I, J LOGICAL MATCH * .. Intrinsic Functions .. INTRINSIC LGE, LLE LOGICAL LGE, LLE * .. * .. Executable Statements .. * * Find the beginning of the next tokens in LN1 and LN2. * I = 1 J = 1 10 IF( ( LN1( I ).EQ.' ' ).AND.( I.LT.LEN1 ) )THEN I = I + 1 GO TO 10 END IF 20 IF( ( LN2( J ).EQ.' ' ).AND.( J.LT.LEN2 ) )THEN J = J + 1 GO TO 20 END IF * * Compare the tokens. * IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.LT.LEN1 ).AND. $ ( J.LT.LEN2 ) )THEN I = I + 1 J = J + 1 GO TO 10 ELSE IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.EQ.LEN1 ).AND. $ ( J.EQ.LEN2 ) )THEN LNCMP = .TRUE. RETURN ELSE IF( ( I.EQ.LEN1 ).AND.( J.EQ.LEN2 ) )THEN LNCMP = .FALSE. RETURN ELSE IF( LN1( I ).EQ.'$' )THEN IF( I.LT.LEN1-1 )THEN IF( LN1( I+1 ).EQ.'$' )THEN I = I + 2 MATCH = .FALSE. 30 IF( ( LGE( LN2( J ), '0' ).AND.LLE( LN2( J ), '9' ) ) $ .AND.( J.LT.LEN2 ) )THEN J = J + 1 MATCH = .TRUE. GO TO 30 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 ELSE IF( LN2( J ).EQ.'$' )THEN IF( J.LT.LEN2-1 )THEN IF( LN2( J+1 ).EQ.'$' )THEN J = J + 2 MATCH = .FALSE. 40 IF( ( LGE( LN1( I ), '0' ).AND.LLE( LN1( I ), '9' ) ) $ .AND.( I.LT.LEN1 ) )THEN I = I + 1 MATCH = .TRUE. GO TO 40 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 END IF * LNCMP = .FALSE. RETURN * * End of LNCMP. * END SHAR_EOF fi # end of overwriting check if test -f 'dsymm.f' then echo shar: will not over-write existing file "'dsymm.f'" else cat << SHAR_EOF > 'dsymm.f' SUBROUTINE DSYMM( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DSYMM performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is a symmetric matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the symmetric matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the symmetric matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * symmetric matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * symmetric matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DCOPY * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 ) * .. User specified parameters for DSYMM .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. DOUBLE PRECISION T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSYMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL DGEMM ( 'N', 'N', M, N, 0, ZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by DCOPY is CB. * DO 30, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 20, J = JJ+1, II+ISEC-1 CALL DCOPY ( MIN( JSEC, J-JJ ), A( JJ, J ), 1, $ T1( J-II+1, JJ-II+1 ), RCB ) 20 CONTINUE 30 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, DGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL DGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 80, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 50, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 50 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by DCOPY is CB. * DO 70, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 60, J = II, JJ+JSEC-2 CALL DCOPY ( MIN( JSEC, JJ+JSEC-1-J ), $ A( MAX( JJ, J+1 ), J ), 1, $ T1( J-II+1, MAX( JJ-II+1, J-II+2 ) ), RCB ) 60 CONTINUE 70 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, DGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL DGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF 80 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 120, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 90, J = JJ, JJ+JSEC-1 CALL DCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 90 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by DCOPY is CB. * DO 110, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 100, I = II+1, JJ+JSEC-1 CALL DCOPY ( MIN( ISEC, I-II ), A( II, I ), 1, $ T1( I-JJ+1, II-JJ+1 ), RCB ) 100 CONTINUE 110 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, DGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL DGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF 120 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 160, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL DCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 130 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by DCOPY is CB. * DO 150, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 140, I = JJ, II+ISEC-2 CALL DCOPY ( MIN( ISEC, II+ISEC-1-I ), $ A( MAX( II, I+1 ), I ), 1, $ T1( I-JJ+1, MAX( II-JJ+1, I-JJ+2 ) ), RCB ) 140 CONTINUE 150 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, DGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL DGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 160 CONTINUE END IF END IF * RETURN * * End of DSYMM. * END SHAR_EOF fi # end of overwriting check if test -f 'dsyr2k.f' then echo shar: will not over-write existing file "'dsyr2k.f'" else cat << SHAR_EOF > 'dsyr2k.f' SUBROUTINE DSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DSYR2K performs one of the symmetric rank 2k operations * * C := alpha*A*B' + alpha*B*A' + beta*C, * * or * * C := alpha*A'*B + alpha*B'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A and B are n by k matrices in the first case and k by n * matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + * beta*C. * * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + * beta*C. * * TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number * of rows of the matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993 * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, JJ, JX, JSEC LOGICAL UPPER, NOTR * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DAXPY, DSCAL * .. Parameters .. DOUBLE PRECISION ONE, ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. User specified parameters for DSYR2K .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. DOUBLE PRECISION T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSYR2K', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL DSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL DSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Upper, Notr. * DO 70, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL DGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL DAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by DAXPY is CB. * DO 60, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 50, I = JJ, II+ISEC-1 CALL DAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 50 CONTINUE 60 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, BETA, $ C( 1, II ), LDC ) CALL DGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ONE, $ C( 1, II ), LDC ) END IF 70 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Upper, Trans. * DO 120, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A'*B, general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL DGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 80, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, C( II, I ), 1 ) 80 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 90, I = II, II+ISEC-1 CALL DAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 90 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by DAXPY is CB. * DO 110, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 100, I = JJ, II+ISEC-1 CALL DAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 100 CONTINUE 110 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, BETA, $ C( 1, II ), LDC ) CALL DGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( 1, II ), LDA, ONE, $ C( 1, II ), LDC ) END IF 120 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Lower, Notr. * DO 170, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL DGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 130, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 130 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 140, I = II, II+ISEC-1 CALL DAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 140 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by DAXPY is CB. * DO 160, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 150, I = II, JJ+JSEC-1 CALL DAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 150 CONTINUE 160 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL DGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ B( II+ISEC, 1 ), LDB, A( II, 1 ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 170 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Lower, Trans. * DO 220, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL DGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 180, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 180 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 190, I = II, II+ISEC-1 CALL DAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 190 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by DAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 CALL DAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 200 CONTINUE 210 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL DGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ B( 1, II+ISEC ), LDB, A( 1, II ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 220 CONTINUE END IF END IF * RETURN * * End of DSYR2K. * END SHAR_EOF fi # end of overwriting check if test -f 'dsyrk.f' then echo shar: will not over-write existing file "'dsyrk.f'" else cat << SHAR_EOF > 'dsyrk.f' SUBROUTINE DSYRK( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * DSYRK performs one of the symmetric rank k operations * * C := alpha*A*A' + beta*C, * * or * * C := alpha*A'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A is an n by k matrix in the first case and a k by n matrix * in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. * * TRANS = 'T' or 't' C := alpha*A'*A + beta*C. * * TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number * of rows of the matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK DOUBLE PRECISION DELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME, DBIGP, DCLD EXTERNAL LSAME, DBIGP, DCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DGEMV, DSYR, DCOPY, DSCAL * .. Parameters .. DOUBLE PRECISION ONE, ZERO INTEGER DIP41, DIP42 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ DIP41 = 41, DIP42 = 42 ) * .. User specified parameters for DSYRK .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) * .. Local Arrays .. DOUBLE PRECISION T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSYRK ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL DSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL DSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Upper, Notr. * SMALLN = .NOT.DBIGP( DIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.DBIGP( DIP42 , N, K ) DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 40, L = 1, K CALL DSYR ( 'U', ISEC, ALPHA, A( II, L ), 1, $ C( II, II ), LDC ) 40 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 50, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 50 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 60, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 60 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having upper * triangular storage format. * DO 70, L = 1, K CALL DSYR ( 'U', ISEC, ALPHA, A( II, L ), 1, $ T2( 1, 1 ), RCB ) 70 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 80, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 80 CONTINUE END IF 90 CONTINUE ELSE DO 130, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 120, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 100, L = LL, LL+LSEC-1 CALL DCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 100 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 110, I = II, II+ISEC-1 CALL DGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 110 CONTINUE DELTA = ONE 120 CONTINUE 130 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Upper, Trans. * SMALLN = .NOT.DBIGP( DIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.DBIGP( DIP42 , N, K ) DO 220, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 140, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, C( II, I ), 1 ) 140 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 150, L = 1, K CALL DSYR ( 'U', ISEC, ALPHA, A( L, II ), LDA, $ C( II, II ), LDC ) 150 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 160, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 160 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 170, I = II, II+ISEC-1 CALL DSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 170 CONTINUE END IF DO 200, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 180, I = II, II+ISEC-1 CALL DCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 180 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * upper triangular storage format. * DO 190, L = LL, LL+LSEC-1 CALL DSYR ( 'U', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 190 CONTINUE 200 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 210, I = II, II+ISEC-1 CALL DCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 210 CONTINUE END IF 220 CONTINUE ELSE CLDA = DCLD( LDA ) DO 270, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 260, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 230, I = II, II+ISEC-1 CALL DCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 230 CONTINUE ELSE DO 240, L = LL, LL+LSEC-1 CALL DCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 240 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 250, I = II, II+ISEC-1 CALL DGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 250 CONTINUE DELTA = ONE 260 CONTINUE 270 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Lower, Notr. * SMALLN = .NOT.DBIGP( DIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.DBIGP( DIP42 , N, K ) DO 340, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 280, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 280 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 290, L = 1, K CALL DSYR ( 'L', ISEC, ALPHA, A( II, L ), 1, $ C( II, II ), LDC ) 290 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 300, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 300 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 310, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having lower * triangular storage format. * DO 320, L = 1, K CALL DSYR ( 'L', ISEC, ALPHA, A( II, L ), 1, $ T2( 1, 1 ), RCB ) 320 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 330, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 330 CONTINUE END IF * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 340 CONTINUE ELSE DO 380, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 370, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 350, L = LL, LL+LSEC-1 CALL DCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 350 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 360, I = II, II+ISEC-1 CALL DGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 360 CONTINUE DELTA = ONE 370 CONTINUE * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 380 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Lower, Trans. * SMALLN = .NOT.DBIGP( DIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.DBIGP( DIP42 , N, K ) DO 470, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 390, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 400, L = 1, K CALL DSYR ( 'L', ISEC, ALPHA, A( L, II ), LDA, $ C( II, II ), LDC ) 400 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 410, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 410 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 420, I = II, II+ISEC-1 CALL DSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 420 CONTINUE END IF DO 450, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 430, I = II, II+ISEC-1 CALL DCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 430 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * lower triangular storage format. * DO 440, L = LL, LL+LSEC-1 CALL DSYR ( 'L', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 440 CONTINUE 450 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 460, I = II, II+ISEC-1 CALL DCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 460 CONTINUE END IF * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 470 CONTINUE ELSE CLDA = DCLD( LDA ) DO 520, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 510, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 480, I = II, II+ISEC-1 CALL DCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 480 CONTINUE ELSE DO 490, L = LL, LL+LSEC-1 CALL DCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 490 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 500, I = II, II+ISEC-1 CALL DGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 500 CONTINUE DELTA = ONE 510 CONTINUE * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL DGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 520 CONTINUE END IF END IF END IF * RETURN * * End of DSYRK. * END SHAR_EOF fi # end of overwriting check if test -f 'dtrmm.f' then echo shar: will not over-write existing file "'dtrmm.f'" else cat << SHAR_EOF > 'dtrmm.f' SUBROUTINE DTRMM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * DTRMM performs one of the matrix-matrix operations * * C := alpha*op( A )*C, or C := alpha*C*op( A ), * * where alpha is a scalar, C is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies C from * the left or right as follows: * * SIDE = 'L' or 'l' C := alpha*op( A )*C. * * SIDE = 'R' or 'r' C := alpha*C*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, and on exit is overwritten by the * transformed matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOUNIT, CLDC, SMALLN, $ TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC DOUBLE PRECISION GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD * .. External Functions .. LOGICAL LSAME, DBIGP, DCLD EXTERNAL LSAME, DBIGP, DCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DGEMV, DTRMV, DCOPY * .. Parameters .. DOUBLE PRECISION ZERO, ONE INTEGER DIP81, DIP82, DIP83 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ DIP81 = 81, DIP82 = 82, DIP83 = 83 ) * .. User specified parameters for DTRMM .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) DOUBLE PRECISION T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL DGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*C. Left, Upper, No transpose. * SMALLN = .NOT.DBIGP( DIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.DBIGP( DIP82, M, N ) DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 10, J = 1, N CALL DTRMV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * C := T3*C, triangular matrix multiply involving * a upper triangular diagonal block of A stored * in T3. * DO 30, J = 1, N CALL DTRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE DELTA = ALPHA CLDC = DCLD( LDC ) DO 110, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in DGEMV that appears if the second * dimension (tsec) is zero. * DO 80, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 110 CONTINUE END IF ELSE * * Form C := alpha*A'*C. Left, Upper, Transpose. * SMALLN = .NOT.DBIGP( DIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.DBIGP( DIP82, M, N ) DO 150, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'T', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 120, J = 1, N CALL DTRMV ( 'U', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A', the transpose of a upper unit or * non-unit triangular diagonal block of A is * copied to the lower triangular part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( I-II+1, 1 ), RCB ) 130 CONTINUE * * C := T3*C, triangular matrix multiply involving * the transpose of a upper triangular diagonal * block of A stored in T3. * DO 140, J = 1, N CALL DTRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 150 CONTINUE ELSE DELTA = ALPHA CLDC = DCLD( LDC ) DO 210, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) DO 200, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 160, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 160 CONTINUE ELSE DO 170, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 170 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 180, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( I, I ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( II, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 180 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 190, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 190 CONTINUE 200 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 210 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*C. Left, Lower, No transpose. * SMALLN = .NOT.DBIGP( DIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.DBIGP( DIP82, M, N ) DO 250, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 220, J = 1, N CALL DTRMV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 220 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. * DO 230, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 230 CONTINUE * * C := T3*C, triangular matrix multiply involving * a lower triangular diagonal block of A stored * in T3. * DO 240, J = 1, N CALL DTRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 240 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 250 CONTINUE ELSE DELTA = ALPHA CLDC = DCLD( LDC ) DO 320, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 260, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 260 CONTINUE DO 310, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 270, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 280 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in DGEMV that appears if the second * dimension (tsec) is zero. * DO 290, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 290 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 300, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 300 CONTINUE 310 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL DGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 320 CONTINUE END IF ELSE * * Form C := alpha*A'*C. Left, Lower, Transpose. * SMALLN = .NOT.DBIGP( DIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.DBIGP( DIP82, M, N ) DO 360, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'T', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 330, J = 1, N CALL DTRMV ( 'L', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 330 CONTINUE ELSE * * T3 := A', the transpose of a lower unit or * non-unit triangular diagonal block of A is * copied to the upper triangular part of T3. * DO 340, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1, I-II+1+OFFD ), RCB ) 340 CONTINUE * * C := alpha*T3*C, triangular matrix multiply * involving the transpose of a lower triangular * diagonal block of A stored in T3. * DO 350, J = 1, N CALL DTRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 350 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 360 CONTINUE ELSE DELTA = ALPHA CLDC = DCLD( LDC ) DO 420, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 DO 410, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 370, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 370 CONTINUE ELSE DO 380, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 380 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 390, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( I, I ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, A( I+TIJ, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 390 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 400, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 400 CONTINUE 410 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 420 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*C*A. Right, Upper, No transpose. * TINYM = .NOT.DBIGP( DIP83, M, N ) IF( TINYM )THEN DO 440, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 430, I = 1, M CALL DTRMV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 430 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 440 CONTINUE ELSE DELTA = ALPHA DO 480, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) DO 470, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 450, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 450 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 460, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 480 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Upper, Transpose. * TINYM = .NOT.DBIGP( DIP83, M, N ) IF( TINYM )THEN DO 500, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'T', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A', triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 490, I = 1, M CALL DTRMV ( 'U', 'N', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 500 CONTINUE ELSE DELTA = ALPHA DO 550, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 510, J = JJ+OFFD, JJ+JSEC-1 CALL DCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 510 CONTINUE DO 540, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 520, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 520 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 530, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 530 CONTINUE 540 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 550 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*C*A. Right, Lower, No transpose. * TINYM = .NOT.DBIGP( DIP83, M, N ) IF( TINYM )THEN DO 570, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * lower triangular diagonal block of A. * DO 560, I = 1, M CALL DTRMV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 560 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 570 CONTINUE ELSE DELTA = ALPHA DO 610, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 DO 600, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 580, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 580 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 590, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, C( II, J ), 1 ) 590 CONTINUE 600 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 610 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Lower, Transpose. * TINYM = .NOT.DBIGP( DIP83, M, N ) IF( TINYM )THEN DO 630, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL DGEMM ( 'N', 'T', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A', triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 620, I = 1, M CALL DTRMV ( 'L', 'N', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 620 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 630 CONTINUE ELSE DELTA = ALPHA DO 680, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 640, J = JJ, JJ+JSEC-1-OFFD CALL DCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 640 CONTINUE DO 670, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 650, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 650 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in DGEMV that appears if the * second dimension (tsec) is zero. * DO 660, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 660 CONTINUE 670 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 680 CONTINUE END IF END IF END IF END IF * RETURN * * End of DTRMM. * END SHAR_EOF fi # end of overwriting check if test -f 'dtrsm.f' then echo shar: will not over-write existing file "'dtrsm.f'" else cat << SHAR_EOF > 'dtrsm.f' SUBROUTINE DTRSM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC DOUBLE PRECISION ALPHA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * DTRSM solves one of the matrix equations * * op( A )*X = alpha*C, or X*op( A ) = alpha*C, * * where alpha is a scalar, X and C are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * The matrix X is overwritten on C. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*C. * * SIDE = 'R' or 'r' X*op( A ) = alpha*C. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the right-hand side matrix C, and on exit is * overwritten by the solution matrix X. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOUNIT, CLDC, SMALLN, $ TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC DOUBLE PRECISION GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD * .. External Functions .. LOGICAL LSAME, DBIGP, DCLD EXTERNAL LSAME, DBIGP, DCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL DGEMM, DGEMV, DTRSV, DCOPY * .. Parameters .. DOUBLE PRECISION ZERO, ONE INTEGER DIP91, DIP92, DIP93 PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, $ DIP91 = 91, DIP92 = 92, DIP93 = 93 ) * .. User specified parameters for DTRSM .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) DOUBLE PRECISION T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRSM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL DGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Upper, No transpose. * SMALLN = .NOT.DBIGP( DIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.DBIGP( DIP92, M, N ) DO 40, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a upper triangular diagonal block of A. The * block of X is overwritten on C. * DO 10, J = 1, N CALL DTRSV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * Solve T3*X = C, triangular system solve * involving a upper triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 30, J = 1, N CALL DTRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF 40 CONTINUE ELSE DELTA = ONE CLDC = DCLD( LDC ) DO 110, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 80, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE 110 CONTINUE END IF ELSE * * Solve A'*X = alpha*C. Left, Upper, Transpose. * SMALLN = .NOT.DBIGP( DIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.DBIGP( DIP92, M, N ) DO 150, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL DGEMM ( 'T', 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C, triangular system solve * involving the transpose of a upper triangular * diagonal block of A. The block of X is * overwritten on C. * DO 120, J = 1, N CALL DTRSV ( 'U', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A', the transpose of a upper unit or * non-unit triangular diagonal block of A is * copied to the lower triangular part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL DCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( I-II+1, 1 ), RCB ) 130 CONTINUE * * Solve T3*X = C, triangular system solve * involving the transpose of a upper triangular * diagonal block of A stored in T3. The block of X * is overwritten on C. * DO 140, J = 1, N CALL DTRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF 150 CONTINUE ELSE DELTA = ONE CLDC = DCLD( LDC ) DO 210, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL DGEMM ( 'T', 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) DO 200, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 160, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 160 CONTINUE ELSE DO 170, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 170 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 180, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/A( I, I ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( II, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 180 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 190, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 190 CONTINUE 200 CONTINUE 210 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Lower, No transpose. * SMALLN = .NOT.DBIGP( DIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.DBIGP( DIP92, M, N ) DO 250, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL DGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a lower triangular diagonal block of A. The * block of X is overwritten on C. * DO 220, J = 1, N CALL DTRSV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 220 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. The block of X is * overwritten on C. * DO 230, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 230 CONTINUE * * Solve T3*X = C, triangular system solve * involving a lower triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 240, J = 1, N CALL DTRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 240 CONTINUE END IF 250 CONTINUE ELSE DELTA = ONE CLDC = DCLD( LDC ) DO 320, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL DGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 260, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 260 CONTINUE DO 310, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 270, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 280 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 290, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 290 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 300, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 300 CONTINUE 310 CONTINUE 320 CONTINUE END IF ELSE * * Solve A'*X = alpha*C. Left, Lower, Transpose. * SMALLN = .NOT.DBIGP( DIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.DBIGP( DIP92, M, N ) DO 360, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C, triangular system solve * involving the transpose of a lower triangular * diagonal block of A. The block of X is * overwritten on C. * DO 330, J = 1, N CALL DTRSV ( 'L', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 330 CONTINUE ELSE * * T3 := A', the transpose of a lower unit or * non-unit triangular diagonal block of A is * copied to the upper triangular part of T3. * DO 340, I = II, II+ISEC-1-OFFD CALL DCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1, I-II+1+OFFD ), RCB ) 340 CONTINUE * * Solve T3*X = C, triangular system solve * involving the transpose of a lower triangular * diagonal block of A stored in T3. The block of X * is overwritten on C. * DO 350, J = 1, N CALL DTRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 350 CONTINUE END IF 360 CONTINUE ELSE DELTA = ONE CLDC = DCLD( LDC ) DO 420, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) DO 410, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 370, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 370 CONTINUE ELSE DO 380, I = II, II+ISEC-1 CALL DCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 380 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 390, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/A( I, I ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, A( I+TIJ, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 390 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 400, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 400 CONTINUE 410 CONTINUE 420 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Upper, No transpose. * TINYM = .NOT.DBIGP( DIP93, M, N ) IF( TINYM )THEN DO 440, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a upper triangular diagonal block of A. The block * of X is overwritten on C. * DO 430, I = 1, M CALL DTRSV ( 'U', 'T', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 430 CONTINUE 440 CONTINUE ELSE DELTA = ONE DO 490, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL DGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 480, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 450, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 450 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 460, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 460 CONTINUE * * C := T1, T1 is copied back to C. * DO 470, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 470 CONTINUE 480 CONTINUE 490 CONTINUE END IF ELSE * * Solve X*A' = alpha*C. Right, Upper, Transpose. * TINYM = .NOT.DBIGP( DIP93, M, N ) IF( TINYM )THEN DO 510, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A' = C, triangular system solve involving * the transpose of a upper triangular diagonal block * of A. The block of X is overwritten on C. * DO 500, I = 1, M CALL DTRSV ( 'U', 'N', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 500 CONTINUE 510 CONTINUE ELSE DELTA = ONE DO 570, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 520, J = JJ+OFFD, JJ+JSEC-1 CALL DCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 520 CONTINUE DO 560, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 530, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 530 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 540, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 540 CONTINUE * * C := T1, T1 is copied back to C. * DO 550, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 550 CONTINUE 560 CONTINUE 570 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Lower, No transpose. * TINYM = .NOT.DBIGP( DIP93, M, N ) IF( TINYM )THEN DO 590, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a lower triangular diagonal block of A. The block * of X is overwritten on C. * DO 580, I = 1, M CALL DTRSV ( 'L', 'T', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 580 CONTINUE 590 CONTINUE ELSE DELTA = ONE DO 640, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL DGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 630, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 600, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 600 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 610, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 610 CONTINUE * * C := T1, T1 is copied back to C. * DO 620, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 620 CONTINUE 630 CONTINUE 640 CONTINUE END IF ELSE * * Solve X*A' = alpha*C. Right, Lower, Transpose. * TINYM = .NOT.DBIGP( DIP93, M, N ) IF( TINYM )THEN DO 660, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A' = C, triangular system solve involving * the transpose of a lower triangular diagonal block * of A. The block of X is overwritten on C. * DO 650, I = 1, M CALL DTRSV ( 'L', 'N', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 650 CONTINUE 660 CONTINUE ELSE DELTA = ONE DO 720, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL DGEMM ( 'N', 'T', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 670, J = JJ, JJ+JSEC-1-OFFD CALL DCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 670 CONTINUE DO 710, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 680, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 680 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in DGEMV that * appears if the second dimension (tsec) is zero. * DO 690, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL DGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 690 CONTINUE * * C := T1, T1 is copied back to C. * DO 700, J = JJ, JJ+JSEC-1 CALL DCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 700 CONTINUE 710 CONTINUE 720 CONTINUE END IF END IF END IF END IF * RETURN * * End of DTRSM. * END SHAR_EOF fi # end of overwriting check if test -f 'eoln.f' then echo shar: will not over-write existing file "'eoln.f'" else cat << SHAR_EOF > 'eoln.f' INTEGER FUNCTION EOLN( LN, LLN ) * .. Scalar Arguments .. INTEGER LLN * .. Array Arguments .. CHARACTER LN( LLN ) * * Return the index of the last non-blank character in the last word * (token) of LN. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER IE * .. * .. Executable Statements .. * * Find the end of the last word (token) of LN. * IE = LLN 10 IF( ( LN( IE ).EQ.' ' ).AND.( IE.GE.1 ) )THEN IE = IE - 1 GO TO 10 END IF EOLN = IE * RETURN * * End of EOLN. * END SHAR_EOF fi # end of overwriting check if test -f 'getwrd.f' then echo shar: will not over-write existing file "'getwrd.f'" else cat << SHAR_EOF > 'getwrd.f' LOGICAL FUNCTION GETWRD( LN, LLN, IB, IE ) * .. Scalar Arguments .. INTEGER LLN, IB, IE * .. Array Arguments .. CHARACTER LN( LLN ) * * Read the first non-blank word from the character string LN. Set * the indices IB and IE to the beginning and end of the word, * respectively. Return .TRUE. if a word was found and .FALSE. if no * word was found. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * .. * .. Executable Statements .. * * Find the beginning of the word. * IB = 1 10 IF( ( LN( IB ).EQ.' ' ).AND.( IB.LT.LLN ) )THEN IB = IB + 1 GO TO 10 END IF * * Find the end of the word. * IE = IB 20 IF( IE.LT.LLN )THEN IF( LN( IE+1 ).NE.' ' )THEN IE = IE + 1 GO TO 20 END IF END IF * * Check if any word was found. * IF( LN( IB ).NE.' ' )THEN GETWRD = .TRUE. ELSE GETWRD = .FALSE. END IF * RETURN * * End of GETWRD. * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' ### GEMM-Based Level 3 BLAS ############################################ all: gblib clean: cleangblib gblib: ( cd SGBL3B; $(MAKE) ) ( cd DGBL3B; $(MAKE) ) ( cd CGBL3B; $(MAKE) ) ( cd ZGBL3B; $(MAKE) ) cleangblib: ( cd SGBL3B; $(MAKE) clean ) ( cd DGBL3B; $(MAKE) clean ) ( cd CGBL3B; $(MAKE) clean ) ( cd ZGBL3B; $(MAKE) clean ) SHAR_EOF fi # end of overwriting check if test ! -d 'SGBL3B' then mkdir 'SGBL3B' fi cd 'SGBL3B' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # SGBFLG : the GEMM-based level 3 BLAS routines # SAXFLG : GEMM-based specific auxiliary routines # AXOPT : other auxiliary routines # SGBFLG = $(GBOPT) SAXFLG = $(GBOPT) AXFLG = $(AXOPT) # ### GEMM-based Level 3 BLAS ############################################## AUXS = lsame.f xerbla.f AUX = lsame.o xerbla.o SGBS = ssymm.f ssyrk.f ssyr2k.f strmm.f strsm.f SGB = ssymm.o ssyrk.o ssyr2k.o strmm.o strsm.o SAUXS = sbigp.f scld.f SAUX = sbigp.o scld.o SGPMS = ssgpm.f getwrd.f eoln.f SGPM = ssgpm.o getwrd.o eoln.o ######################################################################## all: $(GBL3B) ssgpm $(GBL3B): $(SGB) $(SAUX) $(AUX) $(ARCH) $(ARCHFLAGS) $(GBL3B) $(SGB) $(SAUX) $(AUX) $(RANLIB) $(GBL3B) ssgpm: $(SGPM) $(LOADER) $(LOADOPT) -o ssgpm $(SGPM) $(SGB): $(SGBS) $(FORTRAN) -c $(SGBFLG) $(SGBS) $(SAUX): $(SAUXS) $(FORTRAN) -c $(SAXFLG) $(SAUXS) $(AUX): $(AUXS) $(FORTRAN) -c $(AXFLG) $(AUXS) $(SGPM): $(SGPMS) $(FORTRAN) -c $(AXFLG) $(SGPMS) clean: rm -f *.o ssgpm SHAR_EOF fi # end of overwriting check if test -f 'eoln.f' then echo shar: will not over-write existing file "'eoln.f'" else cat << SHAR_EOF > 'eoln.f' INTEGER FUNCTION EOLN( LN, LLN ) * .. Scalar Arguments .. INTEGER LLN * .. Array Arguments .. CHARACTER LN( LLN ) * * Return the index of the last non-blank character in the last word * (token) of LN. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER IE * .. * .. Executable Statements .. * * Find the end of the last word (token) of LN. * IE = LLN 10 IF( ( LN( IE ).EQ.' ' ).AND.( IE.GE.1 ) )THEN IE = IE - 1 GO TO 10 END IF EOLN = IE * RETURN * * End of EOLN. * END SHAR_EOF fi # end of overwriting check if test -f 'getwrd.f' then echo shar: will not over-write existing file "'getwrd.f'" else cat << SHAR_EOF > 'getwrd.f' LOGICAL FUNCTION GETWRD( LN, LLN, IB, IE ) * .. Scalar Arguments .. INTEGER LLN, IB, IE * .. Array Arguments .. CHARACTER LN( LLN ) * * Read the first non-blank word from the character string LN. Set * the indices IB and IE to the beginning and end of the word, * respectively. Return .TRUE. if a word was found and .FALSE. if no * word was found. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * .. * .. Executable Statements .. * * Find the beginning of the word. * IB = 1 10 IF( ( LN( IB ).EQ.' ' ).AND.( IB.LT.LLN ) )THEN IB = IB + 1 GO TO 10 END IF * * Find the end of the word. * IE = IB 20 IF( IE.LT.LLN )THEN IF( LN( IE+1 ).NE.' ' )THEN IE = IE + 1 GO TO 20 END IF END IF * * Check if any word was found. * IF( LN( IB ).NE.' ' )THEN GETWRD = .TRUE. ELSE GETWRD = .FALSE. END IF * RETURN * * End of GETWRD. * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'sbigp.f' then echo shar: will not over-write existing file "'sbigp.f'" else cat << SHAR_EOF > 'sbigp.f' LOGICAL FUNCTION SBIGP( IP, DIM1, DIM2 ) * .. Scalar Arguments .. INTEGER IP, DIM1, DIM2 * .. * * Purpose * ======= * * SBIGP determines which of two alternative code sections in a GEMM- * Based Level 3 BLAS routine that will be the fastest for a particular * problem. If the problem is considered large enough SBIGP returns * .TRUE., otherwise .FALSE. is returned. The input parameter IP * specifies the calling routine and a break point for alternative code * sections. The input parameters DIM1 and DIM2 are matrix dimensions. * The returned value is a function of the input parameters and the * performance characteristics of the two alternative code sections. * * In this simple implementation, the returned values are determined by * looking at only one of the two dimensions DIM1 and DIM2. It may be * rewarding to rewrite the logical expressions in SBIGP so that both * dimensions are involved. The returned values should effectively * reflect the performance characteristics of the underlying BLAS * routines. * * * Input * ===== * * IP - INTEGER * On entry, IP specifies which routine and which alternative * code sections that the decision is intended for. * Unchanged on exit. * * DIM1 - INTEGER. * On entry, DIM1 specifies the first dimension in the calling * sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * DIM2 - INTEGER. * On entry, DIM2 specifies the second dimension in the * calling sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. User specified parameters for SBIGP .. INTEGER SIP41, SIP42, SIP81, SIP82, SIP83, $ SIP91, SIP92, SIP93 PARAMETER ( SIP41 = 4, SIP42 = 3, $ SIP81 = 4, SIP82 = 3, SIP83 = 4, $ SIP91 = 4, SIP92 = 3, SIP93 = 4 ) * .. * .. Executable Statements .. IF( IP.EQ.41 )THEN SBIGP = DIM1.GE.SIP41 ELSE IF( IP.EQ.42 )THEN SBIGP = DIM2.GE.SIP42 ELSE IF( IP.EQ.81 )THEN SBIGP = DIM2.GE.SIP81 ELSE IF( IP.EQ.82 )THEN SBIGP = DIM2.GE.SIP82 ELSE IF( IP.EQ.83 )THEN SBIGP = DIM1.GE.SIP83 ELSE IF( IP.EQ.91 )THEN SBIGP = DIM2.GE.SIP91 ELSE IF( IP.EQ.92 )THEN SBIGP = DIM2.GE.SIP92 ELSE IF( IP.EQ.93 )THEN SBIGP = DIM1.GE.SIP93 ELSE SBIGP = .FALSE. END IF * RETURN * * End of SBIGP. * END SHAR_EOF fi # end of overwriting check if test -f 'scld.f' then echo shar: will not over-write existing file "'scld.f'" else cat << SHAR_EOF > 'scld.f' LOGICAL FUNCTION SCLD( LD ) * .. Scalar Arguments .. INTEGER LD * .. * * Purpose * ======= * * The size of the leading dimension of a two-dimensional array may * cause severe problems. Often when an array with a 'critical' leading * dimension is referenced, the execution time becomes significantly * longer than expected. This is caused by shortcomings of the memory * system. * * The function SCLD returns .TRUE. if the leading dimension LD is * critical and .FALSE. if it is not critical. In this implementation * SCLD is designed to detect critical leading dimensions in an * environment with a multi-way associative cache. Parameters defining * cache characteristics are adjustable to match different machines. * It may be rewarding to rewrite SCLD for a machine with a different * cache policy. * * The cache lines in a multi-way associative cache are divided among a * number of partitions, each containing the same number of lines. Each * address of main memory is mapped into a particular partition. The * number of lines in a partition equals the associativity. For example, * in a four way associative cache, each partition contain four cache * lines. * * Data are transferred between the cache and main memory according to * an associative mapping scheme. A transfer of a data word from main * memory to cache is accomplished as follows. A unit of data * (data line) in main memory, with the size of a cache line, and * containing several contiguous data words including the referenced * one, is mapped (copied) to a certain partition in the cache memory. * The partition is determined by the location of the element in the * main memory and the associative mapping scheme. A replacement * algorithm makes room for the data line in one of the cache lines in * the selected partition. For example, an LRU-based (Least Recently * Used) replacement algorithm places the data line in the least * recently 'touched' cache line in the selected partition. * * * Input * ===== * * LD - On entry, LD specifies the leading dimension of a * 2-dimensional array. Unchanged on exit. * * * User specified parameters for SCLD * ================================ * * LNSZ - Size of a cache line in number of bytes. * * NPRT - Number of partitions in the cache memory. * * PRTSZ - The number of cache lines in a partition that can be used * exclusively to hold a local array containing a matrix block * during the execution of a GEMM-Based Level 3 BLAS routine. * The remaining cache lines may be occupied by scalars, * vectors and possibly program code depending on the system. * * LOLIM - Leading dimensions smaller than or equal to LOLIM are not * considered critical. * * SP - Number of bytes in a single-precision word. * * * Local Variables and Parameters * ============================== * * ONEWAY - The maximum number of real words that can be * stored in the cache memory if only a single cache line in * each partition may be used. * * UPDIF - The difference between the multiple of LD that is nearest * ONEWAY, or nearest a multiple of ONEWAY, and the nearest * multiple of ONEWAY that is larger than LD. In number of * real words. * * MXDIF - If both UPDIF and LD - UPDIF are less than MXDIF, and LD * is greater than LOLIM, then the leading dimension is * considered critical. Otherwise, the leading dimension is * considered not critical. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Variables .. INTEGER UPDIF * .. Intrinsic Functions .. INTRINSIC MIN, MOD * .. User specified parameters for SCLD .. INTEGER LOLIM, LNSZ, NPRT, PRTSZ, SP PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, SP = 8 ) * .. Parameters .. INTEGER ONEWAY, MXDIF PARAMETER ( ONEWAY = ( LNSZ*NPRT )/SP, $ MXDIF = LNSZ/( SP*PRTSZ ) ) * .. * .. Executable Statements .. * IF( LD.LE.LOLIM )THEN SCLD = .FALSE. ELSE UPDIF = MOD( ( LD/ONEWAY )*ONEWAY+ONEWAY, LD ) SCLD = MIN( UPDIF, LD-UPDIF ).LE.MXDIF END IF * RETURN * * End of SCLD. * END SHAR_EOF fi # end of overwriting check if test -f 'sgpm.in' then echo shar: will not over-write existing file "'sgpm.in'" else cat << SHAR_EOF > 'sgpm.in' * * Example of an input file for the program SSGPM containing user * specified parameters. * * The enclosed program SSGPM re-writes GEMM-Based Level 3 BLAS source * files replacing lines containing old PARAMETER statements for user * specified parameters, with lines containing new PARAMETER statements * given in an input file. The user can conveniently assign new values * to the PARAMETER statements in the input file, and then run SSGPM to * distribute these values to the GEMM-based routines. An input file * consists of three different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file. Read the file * INSTALL for further instructions on how to use this file. * ssymm.f PARAMETER ( RCB = 128, CB = 64 ) ssyr2k.f PARAMETER ( RCB = 128, CB = 64 ) ssyrk.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) strmm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) strsm.f PARAMETER ( RCB = 64, RB = 64, CB = 64 ) sbigp.f PARAMETER ( SIP41 = 4, SIP42 = 3, $ SIP81 = 4, SIP82 = 3, SIP83 = 4, $ SIP91 = 4, SIP92 = 3, SIP93 = 4 ) scld.f PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 64, SP = 8 ) SHAR_EOF fi # end of overwriting check if test -f 'ssgpm.f' then echo shar: will not over-write existing file "'ssgpm.f'" else cat << SHAR_EOF > 'ssgpm.f' PROGRAM SSGPM * * SSGPM re-writes GEMM-Based Level 3 BLAS source files replacing lines * containing old PARAMETER statements for user specified parameters, * with lines containing new PARAMETER statements given in an input * file. The user can conveniently assign new values to the PARAMETER * statements in the input file, and then run SSGPM to distribute these * values to the GEMM-based routines. An input file consists of three * different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file (see the input file * 'sgpm.in'). Read the file INSTALL for further instructions. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, IB, IE, JB, JE, KB, KE, NAM, NXTLN LOGICAL PMEOF * .. External Functions .. LOGICAL LNCMP, GETWRD INTEGER EOLN EXTERNAL LNCMP, GETWRD, EOLN * .. Parameters .. INTEGER NPM, NGB, NTMP, NERR PARAMETER ( NPM = 5, NERR = 6, NGB = 10, NTMP = 12 ) INTEGER NLNS, LLN PARAMETER ( NLNS = 10, LLN = 256 ) CHARACTER TMPNAM*( LLN ) PARAMETER ( TMPNAM = 'tmpgb.tmp' ) * .. Local Arrays .. CHARACTER PMLN*( LLN ), GBLN*( LLN ), GBNAM*( LLN ), $ STRS( NLNS, 2 )*( LLN ) CHARACTER PMLNA( LLN ), GBLNA( LLN ), GBNAMA( LLN ), $ STRSA( LLN, NLNS, 2 ) EQUIVALENCE ( PMLN, PMLNA ), ( GBLN, GBLNA ), $ ( GBNAM, GBNAMA ), ( STRS, STRSA ) * .. Data statements .. DATA STRS/ $'ssymm.f' ,'ssyrk.f' ,'ssyr2k.f' ,'strmm.f' ,'strsm.f' , $'sbigp.f' ,' ',' ','scld.f' ,' ', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( SIP41 = $$ , SIP42 = $$ ,', $'$ SIP81 = $$ , SIP82 = $$ , SIP83 = $$ ,', $'$ SIP91 = $$ , SIP92 = $$ , SIP93 = $$ )', $'PARAMETER ( LNSZ = $$ , NPRT = $$ , PRTSZ = $$ ,', $'$ LOLIM = $$ , SP = $$ )' / * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. * 10 READ( NPM, FMT = 9000, END = 110 ) GBNAM IF( .NOT.GETWRD( GBNAMA, LLN, IB, IE ).OR. $ ( GBNAM( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * Check if the first word on the line is the name of a file that is * due to be changed. * 20 NAM = -1 PMEOF = .FALSE. DO 30, I = 1, NLNS IF( GBNAM( IB:IE ).EQ.STRS( I, 1 ) )THEN NAM = I END IF 30 CONTINUE IF( NAM.EQ.-1 )THEN WRITE( NERR, FMT = * )'Unknown routine name: ', GBNAM( IB:IE ) STOP END IF * * Read the next non-blank/non-comment line from the input parameter * file. * 40 READ( NPM, FMT = 9000, END = 110 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 40 END IF * * Copy each line of the GEMM-Based file, except for the lines that * are due to be changed, to the temporary file TMPNAM. Copy the * lines that should be changed from the input parameter file. Check * that the lines in the parameter file are correct compared to STRS. * NXTLN = NAM IF( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN OPEN( NGB, FILE = GBNAM( IB:IE ), STATUS = 'OLD' ) OPEN( NTMP, FILE = TMPNAM, STATUS = 'NEW' ) 50 READ( NGB, FMT = 9000, END = 80 ) GBLN IF( LNCMP( GBLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN WRITE( NTMP, FMT = 9010 ) PMLN( 1:EOLN( PMLNA, LLN ) ) 60 READ( NPM, FMT = 9000, END = 70 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 60 END IF IF( .NOT.GETWRD( STRSA( 1, NXTLN+1, 1 ), LLN, KB, KE ).AND. $ ( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN+1, 2 ), LLN ) ) $ )THEN NXTLN = NXTLN + 1 END IF ELSE WRITE( NTMP, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) END IF GO TO 50 70 PMEOF = .TRUE. GO TO 50 80 CLOSE( NGB, STATUS = 'DELETE' ) CLOSE( NTMP, STATUS = 'KEEP' ) ELSE WRITE( NERR, FMT = * )'Error in parameter file: ' WRITE( NERR, FMT = * ) PMLN STOP END IF * * Write back the temporary file TMPNAM to the GEMM-Based file and * remove the temporary file. * OPEN( NTMP, FILE = TMPNAM, STATUS = 'OLD' ) OPEN( NGB, FILE = GBNAM( IB:IE ), STATUS = 'NEW' ) 90 READ( NTMP, FMT = 9000, END = 100 ) GBLN WRITE( NGB, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) GO TO 90 100 CONTINUE CLOSE( NTMP, STATUS = 'DELETE' ) CLOSE( NGB, STATUS = 'KEEP' ) GBNAM = PMLN IB = JB IE = JE * IF( .NOT.PMEOF )THEN GO TO 20 END IF 110 CONTINUE * STOP * 9000 FORMAT( A ) 9010 FORMAT( A ) * * End of SSGPM. * END LOGICAL FUNCTION LNCMP( LN1, LEN1, LN2, LEN2 ) * .. Scalar Arguments .. INTEGER LEN1, LEN2 * .. Array Arguments .. CHARACTER LN1( LEN1 ), LN2( LEN2 ) * * Compare the character strings LN1 and LN2. Return .TRUE. if the * strings are identical except from wild cards ($$) corresponding * to positive integers and except from a different number of * consecutive blanks between tokens. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER I, J LOGICAL MATCH * .. Intrinsic Functions .. INTRINSIC LGE, LLE LOGICAL LGE, LLE * .. * .. Executable Statements .. * * Find the beginning of the next tokens in LN1 and LN2. * I = 1 J = 1 10 IF( ( LN1( I ).EQ.' ' ).AND.( I.LT.LEN1 ) )THEN I = I + 1 GO TO 10 END IF 20 IF( ( LN2( J ).EQ.' ' ).AND.( J.LT.LEN2 ) )THEN J = J + 1 GO TO 20 END IF * * Compare the tokens. * IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.LT.LEN1 ).AND. $ ( J.LT.LEN2 ) )THEN I = I + 1 J = J + 1 GO TO 10 ELSE IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.EQ.LEN1 ).AND. $ ( J.EQ.LEN2 ) )THEN LNCMP = .TRUE. RETURN ELSE IF( ( I.EQ.LEN1 ).AND.( J.EQ.LEN2 ) )THEN LNCMP = .FALSE. RETURN ELSE IF( LN1( I ).EQ.'$' )THEN IF( I.LT.LEN1-1 )THEN IF( LN1( I+1 ).EQ.'$' )THEN I = I + 2 MATCH = .FALSE. 30 IF( ( LGE( LN2( J ), '0' ).AND.LLE( LN2( J ), '9' ) ) $ .AND.( J.LT.LEN2 ) )THEN J = J + 1 MATCH = .TRUE. GO TO 30 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 ELSE IF( LN2( J ).EQ.'$' )THEN IF( J.LT.LEN2-1 )THEN IF( LN2( J+1 ).EQ.'$' )THEN J = J + 2 MATCH = .FALSE. 40 IF( ( LGE( LN1( I ), '0' ).AND.LLE( LN1( I ), '9' ) ) $ .AND.( I.LT.LEN1 ) )THEN I = I + 1 MATCH = .TRUE. GO TO 40 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 END IF * LNCMP = .FALSE. RETURN * * End of LNCMP. * END SHAR_EOF fi # end of overwriting check if test -f 'ssymm.f' then echo shar: will not over-write existing file "'ssymm.f'" else cat << SHAR_EOF > 'ssymm.f' SUBROUTINE SSYMM( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC REAL ALPHA, BETA * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * SSYMM performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is a symmetric matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the symmetric matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the symmetric matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * symmetric matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * symmetric matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SCOPY * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 ) * .. User specified parameters for SSYMM .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. REAL T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SSYMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL SGEMM ( 'N', 'N', M, N, 0, ZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by SCOPY is CB. * DO 30, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 20, J = JJ+1, II+ISEC-1 CALL SCOPY ( MIN( JSEC, J-JJ ), A( JJ, J ), 1, $ T1( J-II+1, JJ-II+1 ), RCB ) 20 CONTINUE 30 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, SGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL SGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 80, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 50, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 50 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by SCOPY is CB. * DO 70, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 60, J = II, JJ+JSEC-2 CALL SCOPY ( MIN( JSEC, JJ+JSEC-1-J ), $ A( MAX( JJ, J+1 ), J ), 1, $ T1( J-II+1, MAX( JJ-II+1, J-II+2 ) ), RCB ) 60 CONTINUE 70 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, SGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL SGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF 80 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 120, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 90, J = JJ, JJ+JSEC-1 CALL SCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 90 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by SCOPY is CB. * DO 110, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 100, I = II+1, JJ+JSEC-1 CALL SCOPY ( MIN( ISEC, I-II ), A( II, I ), 1, $ T1( I-JJ+1, II-JJ+1 ), RCB ) 100 CONTINUE 110 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, SGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL SGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF 120 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 160, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL SCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 130 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by SCOPY is CB. * DO 150, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 140, I = JJ, II+ISEC-2 CALL SCOPY ( MIN( ISEC, II+ISEC-1-I ), $ A( MAX( II, I+1 ), I ), 1, $ T1( I-JJ+1, MAX( II-JJ+1, I-JJ+2 ) ), RCB ) 140 CONTINUE 150 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, SGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL SGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 160 CONTINUE END IF END IF * RETURN * * End of SSYMM. * END SHAR_EOF fi # end of overwriting check if test -f 'ssyr2k.f' then echo shar: will not over-write existing file "'ssyr2k.f'" else cat << SHAR_EOF > 'ssyr2k.f' SUBROUTINE SSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC REAL ALPHA, BETA * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * SSYR2K performs one of the symmetric rank 2k operations * * C := alpha*A*B' + alpha*B*A' + beta*C, * * or * * C := alpha*A'*B + alpha*B'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A and B are n by k matrices in the first case and k by n * matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + * beta*C. * * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + * beta*C. * * TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number * of rows of the matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993 * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, JJ, JX, JSEC LOGICAL UPPER, NOTR * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SAXPY, SSCAL * .. Parameters .. REAL ONE, ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. User specified parameters for SSYR2K .. INTEGER RCB, CB PARAMETER ( RCB = 128, CB = 64 ) * .. Local Arrays .. REAL T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SSYR2K', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL SSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL SSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Upper, Notr. * DO 70, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL SGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL SAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by SAXPY is CB. * DO 60, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 50, I = JJ, II+ISEC-1 CALL SAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 50 CONTINUE 60 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, BETA, $ C( 1, II ), LDC ) CALL SGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ONE, $ C( 1, II ), LDC ) END IF 70 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Upper, Trans. * DO 120, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A'*B, general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL SGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 80, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, C( II, I ), 1 ) 80 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 90, I = II, II+ISEC-1 CALL SAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 90 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by SAXPY is CB. * DO 110, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 100, I = JJ, II+ISEC-1 CALL SAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 100 CONTINUE 110 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, BETA, $ C( 1, II ), LDC ) CALL SGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( 1, II ), LDA, ONE, $ C( 1, II ), LDC ) END IF 120 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Lower, Notr. * DO 170, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL SGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 130, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 130 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 140, I = II, II+ISEC-1 CALL SAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 140 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by SAXPY is CB. * DO 160, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 150, I = II, JJ+JSEC-1 CALL SAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 150 CONTINUE 160 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL SGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ B( II+ISEC, 1 ), LDB, A( II, 1 ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 170 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Lower, Trans. * DO 220, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL SGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 180, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 180 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 190, I = II, II+ISEC-1 CALL SAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 190 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by SAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 CALL SAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 200 CONTINUE 210 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL SGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ B( 1, II+ISEC ), LDB, A( 1, II ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 220 CONTINUE END IF END IF * RETURN * * End of SSYR2K. * END SHAR_EOF fi # end of overwriting check if test -f 'ssyrk.f' then echo shar: will not over-write existing file "'ssyrk.f'" else cat << SHAR_EOF > 'ssyrk.f' SUBROUTINE SSYRK( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC REAL ALPHA, BETA * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * SSYRK performs one of the symmetric rank k operations * * C := alpha*A*A' + beta*C, * * or * * C := alpha*A'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A is an n by k matrix in the first case and a k by n matrix * in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. * * TRANS = 'T' or 't' C := alpha*A'*A + beta*C. * * TRANS = 'C' or 'c' C := alpha*A'*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'T' or 't' or 'C' or 'c', K specifies the number * of rows of the matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - REAL. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK REAL DELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME, SBIGP, SCLD EXTERNAL LSAME, SBIGP, SCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SGEMV, SSYR, SCOPY, SSCAL * .. Parameters .. REAL ONE, ZERO INTEGER SIP41, SIP42 PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0, $ SIP41 = 41, SIP42 = 42 ) * .. User specified parameters for SSYRK .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) * .. Local Arrays .. REAL T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'T' ) ).AND. $ ( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SSYRK ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL SSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL SSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Upper, Notr. * SMALLN = .NOT.SBIGP( SIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.SBIGP( SIP42 , N, K ) DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 40, L = 1, K CALL SSYR ( 'U', ISEC, ALPHA, A( II, L ), 1, $ C( II, II ), LDC ) 40 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 50, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 50 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 60, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 60 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having upper * triangular storage format. * DO 70, L = 1, K CALL SSYR ( 'U', ISEC, ALPHA, A( II, L ), 1, $ T2( 1, 1 ), RCB ) 70 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 80, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 80 CONTINUE END IF 90 CONTINUE ELSE DO 130, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 120, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 100, L = LL, LL+LSEC-1 CALL SCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 100 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 110, I = II, II+ISEC-1 CALL SGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 110 CONTINUE DELTA = ONE 120 CONTINUE 130 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Upper, Trans. * SMALLN = .NOT.SBIGP( SIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.SBIGP( SIP42 , N, K ) DO 220, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 140, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, C( II, I ), 1 ) 140 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 150, L = 1, K CALL SSYR ( 'U', ISEC, ALPHA, A( L, II ), LDA, $ C( II, II ), LDC ) 150 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 160, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 160 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 170, I = II, II+ISEC-1 CALL SSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 170 CONTINUE END IF DO 200, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 180, I = II, II+ISEC-1 CALL SCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 180 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * upper triangular storage format. * DO 190, L = LL, LL+LSEC-1 CALL SSYR ( 'U', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 190 CONTINUE 200 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 210, I = II, II+ISEC-1 CALL SCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 210 CONTINUE END IF 220 CONTINUE ELSE CLDA = SCLD( LDA ) DO 270, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 260, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 230, I = II, II+ISEC-1 CALL SCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 230 CONTINUE ELSE DO 240, L = LL, LL+LSEC-1 CALL SCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 240 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 250, I = II, II+ISEC-1 CALL SGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 250 CONTINUE DELTA = ONE 260 CONTINUE 270 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Lower, Notr. * SMALLN = .NOT.SBIGP( SIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.SBIGP( SIP42 , N, K ) DO 340, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 280, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 280 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 290, L = 1, K CALL SSYR ( 'L', ISEC, ALPHA, A( II, L ), 1, $ C( II, II ), LDC ) 290 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 300, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 300 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 310, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having lower * triangular storage format. * DO 320, L = 1, K CALL SSYR ( 'L', ISEC, ALPHA, A( II, L ), 1, $ T2( 1, 1 ), RCB ) 320 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 330, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 330 CONTINUE END IF * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 340 CONTINUE ELSE DO 380, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 370, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 350, L = LL, LL+LSEC-1 CALL SCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 350 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 360, I = II, II+ISEC-1 CALL SGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 360 CONTINUE DELTA = ONE 370 CONTINUE * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 380 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Lower, Trans. * SMALLN = .NOT.SBIGP( SIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.SBIGP( SIP42 , N, K ) DO 470, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 390, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 400, L = 1, K CALL SSYR ( 'L', ISEC, ALPHA, A( L, II ), LDA, $ C( II, II ), LDC ) 400 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 410, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 410 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 420, I = II, II+ISEC-1 CALL SSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 420 CONTINUE END IF DO 450, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 430, I = II, II+ISEC-1 CALL SCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 430 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * lower triangular storage format. * DO 440, L = LL, LL+LSEC-1 CALL SSYR ( 'L', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 440 CONTINUE 450 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 460, I = II, II+ISEC-1 CALL SCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 460 CONTINUE END IF * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 470 CONTINUE ELSE CLDA = SCLD( LDA ) DO 520, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 510, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 480, I = II, II+ISEC-1 CALL SCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 480 CONTINUE ELSE DO 490, L = LL, LL+LSEC-1 CALL SCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 490 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 500, I = II, II+ISEC-1 CALL SGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 500 CONTINUE DELTA = ONE 510 CONTINUE * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL SGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 520 CONTINUE END IF END IF END IF * RETURN * * End of SSYRK. * END SHAR_EOF fi # end of overwriting check if test -f 'strmm.f' then echo shar: will not over-write existing file "'strmm.f'" else cat << SHAR_EOF > 'strmm.f' SUBROUTINE STRMM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC REAL ALPHA * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * STRMM performs one of the matrix-matrix operations * * C := alpha*op( A )*C, or C := alpha*C*op( A ), * * where alpha is a scalar, C is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies C from * the left or right as follows: * * SIDE = 'L' or 'l' C := alpha*op( A )*C. * * SIDE = 'R' or 'r' C := alpha*C*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, and on exit is overwritten by the * transformed matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOUNIT, CLDC, SMALLN, $ TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC REAL GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD * .. External Functions .. LOGICAL LSAME, SBIGP, SCLD EXTERNAL LSAME, SBIGP, SCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SGEMV, STRMV, SCOPY * .. Parameters .. REAL ZERO, ONE INTEGER SIP81, SIP82, SIP83 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ SIP81 = 81, SIP82 = 82, SIP83 = 83 ) * .. User specified parameters for STRMM .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) REAL T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'STRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL SGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*C. Left, Upper, No transpose. * SMALLN = .NOT.SBIGP( SIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.SBIGP( SIP82, M, N ) DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 10, J = 1, N CALL STRMV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * C := T3*C, triangular matrix multiply involving * a upper triangular diagonal block of A stored * in T3. * DO 30, J = 1, N CALL STRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE DELTA = ALPHA CLDC = SCLD( LDC ) DO 110, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in SGEMV that appears if the second * dimension (tsec) is zero. * DO 80, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 110 CONTINUE END IF ELSE * * Form C := alpha*A'*C. Left, Upper, Transpose. * SMALLN = .NOT.SBIGP( SIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.SBIGP( SIP82, M, N ) DO 150, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'T', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 120, J = 1, N CALL STRMV ( 'U', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A', the transpose of a upper unit or * non-unit triangular diagonal block of A is * copied to the lower triangular part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( I-II+1, 1 ), RCB ) 130 CONTINUE * * C := T3*C, triangular matrix multiply involving * the transpose of a upper triangular diagonal * block of A stored in T3. * DO 140, J = 1, N CALL STRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 150 CONTINUE ELSE DELTA = ALPHA CLDC = SCLD( LDC ) DO 210, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) DO 200, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 160, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 160 CONTINUE ELSE DO 170, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 170 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 180, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( I, I ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( II, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 180 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 190, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 190 CONTINUE 200 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 210 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*C. Left, Lower, No transpose. * SMALLN = .NOT.SBIGP( SIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.SBIGP( SIP82, M, N ) DO 250, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 220, J = 1, N CALL STRMV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 220 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. * DO 230, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 230 CONTINUE * * C := T3*C, triangular matrix multiply involving * a lower triangular diagonal block of A stored * in T3. * DO 240, J = 1, N CALL STRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 240 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 250 CONTINUE ELSE DELTA = ALPHA CLDC = SCLD( LDC ) DO 320, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 260, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 260 CONTINUE DO 310, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 270, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 280 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in SGEMV that appears if the second * dimension (tsec) is zero. * DO 290, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 290 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 300, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 300 CONTINUE 310 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL SGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 320 CONTINUE END IF ELSE * * Form C := alpha*A'*C. Left, Lower, Transpose. * SMALLN = .NOT.SBIGP( SIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.SBIGP( SIP82, M, N ) DO 360, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'T', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 330, J = 1, N CALL STRMV ( 'L', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 330 CONTINUE ELSE * * T3 := A', the transpose of a lower unit or * non-unit triangular diagonal block of A is * copied to the upper triangular part of T3. * DO 340, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1, I-II+1+OFFD ), RCB ) 340 CONTINUE * * C := alpha*T3*C, triangular matrix multiply * involving the transpose of a lower triangular * diagonal block of A stored in T3. * DO 350, J = 1, N CALL STRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 350 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 360 CONTINUE ELSE DELTA = ALPHA CLDC = SCLD( LDC ) DO 420, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 DO 410, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 370, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 370 CONTINUE ELSE DO 380, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 380 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 390, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( I, I ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, A( I+TIJ, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 390 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 400, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 400 CONTINUE 410 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 420 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*C*A. Right, Upper, No transpose. * TINYM = .NOT.SBIGP( SIP83, M, N ) IF( TINYM )THEN DO 440, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 430, I = 1, M CALL STRMV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 430 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 440 CONTINUE ELSE DELTA = ALPHA DO 480, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) DO 470, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 450, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 450 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 460, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 480 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Upper, Transpose. * TINYM = .NOT.SBIGP( SIP83, M, N ) IF( TINYM )THEN DO 500, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'T', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A', triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 490, I = 1, M CALL STRMV ( 'U', 'N', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 500 CONTINUE ELSE DELTA = ALPHA DO 550, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 510, J = JJ+OFFD, JJ+JSEC-1 CALL SCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 510 CONTINUE DO 540, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 520, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 520 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 530, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 530 CONTINUE 540 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 550 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*C*A. Right, Lower, No transpose. * TINYM = .NOT.SBIGP( SIP83, M, N ) IF( TINYM )THEN DO 570, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * lower triangular diagonal block of A. * DO 560, I = 1, M CALL STRMV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 560 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 570 CONTINUE ELSE DELTA = ALPHA DO 610, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 DO 600, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 580, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 580 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 590, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, C( II, J ), 1 ) 590 CONTINUE 600 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 610 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Lower, Transpose. * TINYM = .NOT.SBIGP( SIP83, M, N ) IF( TINYM )THEN DO 630, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL SGEMM ( 'N', 'T', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A', triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 620, I = 1, M CALL STRMV ( 'L', 'N', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 620 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 630 CONTINUE ELSE DELTA = ALPHA DO 680, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 640, J = JJ, JJ+JSEC-1-OFFD CALL SCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 640 CONTINUE DO 670, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 650, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 650 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in SGEMV that appears if the * second dimension (tsec) is zero. * DO 660, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 660 CONTINUE 670 CONTINUE * * C := alpha*C*A' + C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 680 CONTINUE END IF END IF END IF END IF * RETURN * * End of STRMM. * END SHAR_EOF fi # end of overwriting check if test -f 'strsm.f' then echo shar: will not over-write existing file "'strsm.f'" else cat << SHAR_EOF > 'strsm.f' SUBROUTINE STRSM( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC REAL ALPHA * .. Array Arguments .. REAL A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * STRSM solves one of the matrix equations * * op( A )*X = alpha*C, or X*op( A ) = alpha*C, * * where alpha is a scalar, X and C are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A'. * * The matrix X is overwritten on C. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*C. * * SIDE = 'R' or 'r' X*op( A ) = alpha*C. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = A'. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - REAL. * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the right-hand side matrix C, and on exit is * overwritten by the solution matrix X. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOUNIT, CLDC, SMALLN, $ TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC REAL GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD * .. External Functions .. LOGICAL LSAME, SBIGP, SCLD EXTERNAL LSAME, SBIGP, SCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL SGEMM, SGEMV, STRSV, SCOPY * .. Parameters .. REAL ZERO, ONE INTEGER SIP91, SIP92, SIP93 PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, $ SIP91 = 91, SIP92 = 92, SIP93 = 93 ) * .. User specified parameters for STRSM .. INTEGER RB, CB, RCB PARAMETER ( RCB = 64, RB = 64, CB = 64 ) REAL T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANSA, 'T' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'STRSM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL SGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Upper, No transpose. * SMALLN = .NOT.SBIGP( SIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.SBIGP( SIP92, M, N ) DO 40, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a upper triangular diagonal block of A. The * block of X is overwritten on C. * DO 10, J = 1, N CALL STRSV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * Solve T3*X = C, triangular system solve * involving a upper triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 30, J = 1, N CALL STRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF 40 CONTINUE ELSE DELTA = ONE CLDC = SCLD( LDC ) DO 110, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 80, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE 110 CONTINUE END IF ELSE * * Solve A'*X = alpha*C. Left, Upper, Transpose. * SMALLN = .NOT.SBIGP( SIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.SBIGP( SIP92, M, N ) DO 150, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL SGEMM ( 'T', 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C, triangular system solve * involving the transpose of a upper triangular * diagonal block of A. The block of X is * overwritten on C. * DO 120, J = 1, N CALL STRSV ( 'U', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A', the transpose of a upper unit or * non-unit triangular diagonal block of A is * copied to the lower triangular part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL SCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( I-II+1, 1 ), RCB ) 130 CONTINUE * * Solve T3*X = C, triangular system solve * involving the transpose of a upper triangular * diagonal block of A stored in T3. The block of X * is overwritten on C. * DO 140, J = 1, N CALL STRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF 150 CONTINUE ELSE DELTA = ONE CLDC = SCLD( LDC ) DO 210, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL SGEMM ( 'T', 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) DO 200, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 160, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 160 CONTINUE ELSE DO 170, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 170 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 180, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/A( I, I ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( II, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 180 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 190, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 190 CONTINUE 200 CONTINUE 210 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Lower, No transpose. * SMALLN = .NOT.SBIGP( SIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.SBIGP( SIP92, M, N ) DO 250, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL SGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a lower triangular diagonal block of A. The * block of X is overwritten on C. * DO 220, J = 1, N CALL STRSV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 220 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. The block of X is * overwritten on C. * DO 230, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 230 CONTINUE * * Solve T3*X = C, triangular system solve * involving a lower triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 240, J = 1, N CALL STRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 240 CONTINUE END IF 250 CONTINUE ELSE DELTA = ONE CLDC = SCLD( LDC ) DO 320, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL SGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 260, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 260 CONTINUE DO 310, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 270, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 280 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 290, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 290 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 300, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 300 CONTINUE 310 CONTINUE 320 CONTINUE END IF ELSE * * Solve A'*X = alpha*C. Left, Lower, Transpose. * SMALLN = .NOT.SBIGP( SIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.SBIGP( SIP92, M, N ) DO 360, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C, triangular system solve * involving the transpose of a lower triangular * diagonal block of A. The block of X is * overwritten on C. * DO 330, J = 1, N CALL STRSV ( 'L', 'T', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 330 CONTINUE ELSE * * T3 := A', the transpose of a lower unit or * non-unit triangular diagonal block of A is * copied to the upper triangular part of T3. * DO 340, I = II, II+ISEC-1-OFFD CALL SCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1, I-II+1+OFFD ), RCB ) 340 CONTINUE * * Solve T3*X = C, triangular system solve * involving the transpose of a lower triangular * diagonal block of A stored in T3. The block of X * is overwritten on C. * DO 350, J = 1, N CALL STRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 350 CONTINUE END IF 360 CONTINUE ELSE DELTA = ONE CLDC = SCLD( LDC ) DO 420, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) DO 410, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 370, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 370 CONTINUE ELSE DO 380, I = II, II+ISEC-1 CALL SCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 380 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 390, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/A( I, I ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, A( I+TIJ, I ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 390 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 400, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 400 CONTINUE 410 CONTINUE 420 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Upper, No transpose. * TINYM = .NOT.SBIGP( SIP93, M, N ) IF( TINYM )THEN DO 440, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a upper triangular diagonal block of A. The block * of X is overwritten on C. * DO 430, I = 1, M CALL STRSV ( 'U', 'T', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 430 CONTINUE 440 CONTINUE ELSE DELTA = ONE DO 490, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL SGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 480, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 450, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 450 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 460, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 460 CONTINUE * * C := T1, T1 is copied back to C. * DO 470, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 470 CONTINUE 480 CONTINUE 490 CONTINUE END IF ELSE * * Solve X*A' = alpha*C. Right, Upper, Transpose. * TINYM = .NOT.SBIGP( SIP93, M, N ) IF( TINYM )THEN DO 510, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A' = C, triangular system solve involving * the transpose of a upper triangular diagonal block * of A. The block of X is overwritten on C. * DO 500, I = 1, M CALL STRSV ( 'U', 'N', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 500 CONTINUE 510 CONTINUE ELSE DELTA = ONE DO 570, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 520, J = JJ+OFFD, JJ+JSEC-1 CALL SCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 520 CONTINUE DO 560, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 530, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 530 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 540, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 540 CONTINUE * * C := T1, T1 is copied back to C. * DO 550, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 550 CONTINUE 560 CONTINUE 570 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Lower, No transpose. * TINYM = .NOT.SBIGP( SIP93, M, N ) IF( TINYM )THEN DO 590, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a lower triangular diagonal block of A. The block * of X is overwritten on C. * DO 580, I = 1, M CALL STRSV ( 'L', 'T', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 580 CONTINUE 590 CONTINUE ELSE DELTA = ONE DO 640, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL SGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 630, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 600, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 600 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 610, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 610 CONTINUE * * C := T1, T1 is copied back to C. * DO 620, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 620 CONTINUE 630 CONTINUE 640 CONTINUE END IF ELSE * * Solve X*A' = alpha*C. Right, Lower, Transpose. * TINYM = .NOT.SBIGP( SIP93, M, N ) IF( TINYM )THEN DO 660, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A' = C, triangular system solve involving * the transpose of a lower triangular diagonal block * of A. The block of X is overwritten on C. * DO 650, I = 1, M CALL STRSV ( 'L', 'N', DIAG, JSEC, A( JJ, JJ ), $ LDA, C( I, JJ ), LDC ) 650 CONTINUE 660 CONTINUE ELSE DELTA = ONE DO 720, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C, general matrix multiply * involving the transpose of a rectangular block * of A. * CALL SGEMM ( 'N', 'T', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 670, J = JJ, JJ+JSEC-1-OFFD CALL SCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 670 CONTINUE DO 710, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 680, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 680 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in SGEMV that * appears if the second dimension (tsec) is zero. * DO 690, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL SGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 690 CONTINUE * * C := T1, T1 is copied back to C. * DO 700, J = JJ, JJ+JSEC-1 CALL SCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 700 CONTINUE 710 CONTINUE 720 CONTINUE END IF END IF END IF END IF * RETURN * * End of STRSM. * END SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'ZGBL3B' then mkdir 'ZGBL3B' fi cd 'ZGBL3B' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.gbinc ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # ZGBFLG : the GEMM-based level 3 BLAS routines # ZAXFLG : GEMM-based specific auxiliary routines # AXOPT : other auxiliary routines # ZGBFLG = $(GBOPT) ZAXFLG = $(GBOPT) AXFLG = $(AXOPT) # ### GEMM-based Level 3 BLAS ############################################## ZGBS = zsymm.f zhemm.f zsyrk.f zherk.f zsyr2k.f zher2k.f \ ztrmm.f ztrsm.f ZGB = zsymm.o zhemm.o zsyrk.o zherk.o zsyr2k.o zher2k.o \ ztrmm.o ztrsm.o ZAUXS = zbigp.f zcld.f ZAUX = zbigp.o zcld.o AUXS = lsame.f xerbla.f AUX = lsame.o xerbla.o ZGPMS = zsgpm.f getwrd.f eoln.f ZGPM = zsgpm.o getwrd.o eoln.o ######################################################################## all: $(GBL3B) zsgpm $(GBL3B): $(ZGB) $(ZAUX) $(AUX) $(ARCH) $(ARCHFLAGS) $(GBL3B) $(ZGB) $(ZAUX) $(AUX) $(RANLIB) $(GBL3B) zsgpm: $(ZGPM) $(LOADER) $(LOADOPT) -o zsgpm $(ZGPM) $(ZGB): $(ZGBS) $(FORTRAN) -c $(ZGBFLG) $(ZGBS) $(ZAUX): $(ZAUXS) $(FORTRAN) -c $(ZAXFLG) $(ZAUXS) $(AUX): $(AUXS) $(FORTRAN) -c $(AXFLG) $(AUXS) $(ZGPM): $(ZGPMS) $(FORTRAN) -c $(AXFLG) $(ZGPMS) clean: rm -f *.o zsgpm SHAR_EOF fi # end of overwriting check if test -f 'eoln.f' then echo shar: will not over-write existing file "'eoln.f'" else cat << SHAR_EOF > 'eoln.f' INTEGER FUNCTION EOLN( LN, LLN ) * .. Scalar Arguments .. INTEGER LLN * .. Array Arguments .. CHARACTER LN( LLN ) * * Return the index of the last non-blank character in the last word * (token) of LN. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER IE * .. * .. Executable Statements .. * * Find the end of the last word (token) of LN. * IE = LLN 10 IF( ( LN( IE ).EQ.' ' ).AND.( IE.GE.1 ) )THEN IE = IE - 1 GO TO 10 END IF EOLN = IE * RETURN * * End of EOLN. * END SHAR_EOF fi # end of overwriting check if test -f 'getwrd.f' then echo shar: will not over-write existing file "'getwrd.f'" else cat << SHAR_EOF > 'getwrd.f' LOGICAL FUNCTION GETWRD( LN, LLN, IB, IE ) * .. Scalar Arguments .. INTEGER LLN, IB, IE * .. Array Arguments .. CHARACTER LN( LLN ) * * Read the first non-blank word from the character string LN. Set * the indices IB and IE to the beginning and end of the word, * respectively. Return .TRUE. if a word was found and .FALSE. if no * word was found. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * .. * .. Executable Statements .. * * Find the beginning of the word. * IB = 1 10 IF( ( LN( IB ).EQ.' ' ).AND.( IB.LT.LLN ) )THEN IB = IB + 1 GO TO 10 END IF * * Find the end of the word. * IE = IB 20 IF( IE.LT.LLN )THEN IF( LN( IE+1 ).NE.' ' )THEN IE = IE + 1 GO TO 20 END IF END IF * * Check if any word was found. * IF( LN( IB ).NE.' ' )THEN GETWRD = .TRUE. ELSE GETWRD = .FALSE. END IF * RETURN * * End of GETWRD. * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check if test -f 'zbigp.f' then echo shar: will not over-write existing file "'zbigp.f'" else cat << SHAR_EOF > 'zbigp.f' LOGICAL FUNCTION ZBIGP ( IP, DIM1, DIM2 ) * .. Scalar Arguments .. INTEGER IP, DIM1, DIM2 * .. * * Purpose * ======= * * ZBIGP determines which of two alternative code sections in a GEMM- * Based Level 3 BLAS routine that will be the fastest for a particular * problem. If the problem is considered large enough ZBIGP returns * .TRUE., otherwise .FALSE. is returned. The input parameter IP * specifies the calling routine and a break point for alternative code * sections. The input parameters DIM1 and DIM2 are matrix dimensions. * The returned value is a function of the input parameters and the * performance characteristics of the two alternative code sections. * * In this simple implementation, the returned values are determined by * looking at only one of the two dimensions DIM1 and DIM2. It may be * rewarding to rewrite the logical expressions in ZBIGP so that both * dimensions are involved. The returned values should effectively * reflect the performance characteristics of the underlying BLAS * routines. * * * Input * ===== * * IP - INTEGER * On entry, IP specifies which routine and which alternative * code sections that the decision is intended for. * Unchanged on exit. * * DIM1 - INTEGER. * On entry, DIM1 specifies the first dimension in the calling * sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * DIM2 - INTEGER. * On entry, DIM2 specifies the second dimension in the * calling sequence of the Level 3 routine specified by IP. * Unchanged on exit. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. User specified parameters for ZBIGP .. INTEGER ZIP41, ZIP42, $ ZIP51, ZIP52, $ ZIP81, ZIP82, ZIP83, $ ZIP91, ZIP92, ZIP93 PARAMETER ( ZIP41 = 4, ZIP42 = 3, $ ZIP51 = 4, ZIP52 = 3, $ ZIP81 = 4, ZIP82 = 3, ZIP83 = 4, $ ZIP91 = 4, ZIP92 = 3, ZIP93 = 4 ) * .. * .. Executable Statements .. IF( IP.EQ.41 )THEN ZBIGP = DIM1.GE.ZIP41 ELSE IF( IP.EQ.42 )THEN ZBIGP = DIM2.GE.ZIP42 ELSE IF( IP.EQ.51 )THEN ZBIGP = DIM1.GE.ZIP51 ELSE IF( IP.EQ.52 )THEN ZBIGP = DIM2.GE.ZIP52 ELSE IF( IP.EQ.81 )THEN ZBIGP = DIM2.GE.ZIP81 ELSE IF( IP.EQ.82 )THEN ZBIGP = DIM2.GE.ZIP82 ELSE IF( IP.EQ.83 )THEN ZBIGP = DIM1.GE.ZIP83 ELSE IF( IP.EQ.91 )THEN ZBIGP = DIM2.GE.ZIP91 ELSE IF( IP.EQ.92 )THEN ZBIGP = DIM2.GE.ZIP92 ELSE IF( IP.EQ.93 )THEN ZBIGP = DIM1.GE.ZIP93 ELSE ZBIGP = .FALSE. END IF * RETURN * * End of ZBIGP. * END SHAR_EOF fi # end of overwriting check if test -f 'zcld.f' then echo shar: will not over-write existing file "'zcld.f'" else cat << SHAR_EOF > 'zcld.f' LOGICAL FUNCTION ZCLD ( LD ) * .. Scalar Arguments .. INTEGER LD * .. * * Purpose * ======= * * The size of the leading dimension of a two-dimensional array may * cause severe problems. Often when an array with a 'critical' leading * dimension is referenced, the execution time becomes significantly * longer than expected. This is caused by shortcomings of the memory * system. * * The function ZCLD returns .TRUE. if the leading dimension LD is * critical and .FALSE. if it is not critical. In this implementation * ZCLD is designed to detect critical leading dimensions in an * environment with a multi-way associative cache. Parameters defining * cache characteristics are adjustable to match different machines. * It may be rewarding to rewrite ZCLD for a machine with a different * cache policy. * * The cache lines in a multi-way associative cache are divided among a * number of partitions, each containing the same number of lines. Each * address of main memory is mapped into a particular partition. The * number of lines in a partition equals the associativity. For example, * in a four way associative cache, each partition contain four cache * lines. * * Data are transferred between the cache and main memory according to * an associative mapping scheme. A transfer of a data word from main * memory to cache is accomplished as follows. A unit of data * (data line) in main memory, with the size of a cache line, and * containing several contiguous data words including the referenced * one, is mapped (copied) to a certain partition in the cache memory. * The partition is determined by the location of the element in the * main memory and the associative mapping scheme. A replacement * algorithm makes room for the data line in one of the cache lines in * the selected partition. For example, an LRU-based (Least Recently * Used) replacement algorithm places the data line in the least * recently 'touched' cache line in the selected partition. * * * Input * ===== * * LD - On entry, LD specifies the leading dimension of a * 2-dimensional array. Unchanged on exit. * * * User specified parameters for ZCLD * ================================ * * LNSZ - Size of a cache line in number of bytes. * * NPRT - Number of partitions in the cache memory. * * PRTSZ - The number of cache lines in a partition that can be used * exclusively to hold a local array containing a matrix block * during the execution of a GEMM-Based Level 3 BLAS routine. * The remaining cache lines may be occupied by scalars, * vectors and possibly program code depending on the system. * * LOLIM - Leading dimensions smaller than or equal to LOLIM are not * considered critical. * * ZP - Number of bytes in a double complex-precision word. * * * Local Variables and Parameters * ============================== * * ONEWAY - The maximum number of double precision words that can be * stored in the cache memory if only a single cache line in * each partition may be used. * * UPDIF - The difference between the multiple of LD that is nearest * ONEWAY, or nearest a multiple of ONEWAY, and the nearest * multiple of ONEWAY that is larger than LD. In number of * double precision words. * * MXDIF - If both UPDIF and LD - UPDIF are less than MXDIF, and LD * is greater than LOLIM, then the leading dimension is * considered critical. Otherwise, the leading dimension is * considered not critical. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Variables .. INTEGER UPDIF * .. Intrinsic Functions .. INTRINSIC MIN, MOD * .. User specified parameters for ZCLD .. INTEGER LOLIM, LNSZ, NPRT, PRTSZ, ZP PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 32, ZP = 16 ) * .. Parameters .. INTEGER ONEWAY, MXDIF PARAMETER ( ONEWAY = ( LNSZ*NPRT )/ZP, $ MXDIF = LNSZ/( ZP*PRTSZ ) ) * .. * .. Executable Statements .. * IF( LD.LE.LOLIM )THEN ZCLD = .FALSE. ELSE UPDIF = MOD( ( LD/ONEWAY )*ONEWAY+ONEWAY, LD ) ZCLD = MIN( UPDIF, LD-UPDIF ).LE.MXDIF END IF * RETURN * * End of ZCLD. * END SHAR_EOF fi # end of overwriting check if test -f 'zgpm.in' then echo shar: will not over-write existing file "'zgpm.in'" else cat << SHAR_EOF > 'zgpm.in' * * Example of an input file for the program ZSGPM containing user * specified parameters. * * The enclosed program ZSGPM re-writes GEMM-Based Level 3 BLAS source * files replacing lines containing old PARAMETER statements for user * specified parameters, with lines containing new PARAMETER statements * given in an input file. The user can conveniently assign new values * to the PARAMETER statements in the input file, and then run ZSGPM to * distribute these values to the GEMM-based routines. An input file * consists of three different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file. Read the file * INSTALL for further instructions on how to use this file. * zsymm.f PARAMETER ( RCB = 80, CB = 44 ) zhemm.f PARAMETER ( RCB = 80, CB = 44 ) zsyr2k.f PARAMETER ( RCB = 80, CB = 44 ) zher2k.f PARAMETER ( RCB = 80, CB = 44 ) zsyrk.f PARAMETER ( RCB = 44, RB = 44, CB = 44 ) zherk.f PARAMETER ( RCB = 44, RB = 44, CB = 44 ) ztrmm.f PARAMETER ( RCB = 44, RB = 44, CB = 44 ) ztrsm.f PARAMETER ( RCB = 44, RB = 44, CB = 44 ) zbigp.f PARAMETER ( ZIP41 = 4, ZIP42 = 3, $ ZIP51 = 4, ZIP52 = 3, $ ZIP81 = 4, ZIP82 = 3, ZIP83 = 4, $ ZIP91 = 4, ZIP92 = 3, ZIP93 = 4 ) zcld.f PARAMETER ( LNSZ = 64, NPRT = 128, PRTSZ = 3, $ LOLIM = 32, ZP = 16 ) SHAR_EOF fi # end of overwriting check if test -f 'zhemm.f' then echo shar: will not over-write existing file "'zhemm.f'" else cat << SHAR_EOF > 'zhemm.f' SUBROUTINE ZHEMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZHEMM performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is an hermitian matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the hermitian matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the hermitian matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * hermitian matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * hermitian matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the hermitian matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the hermitian matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the hermitian * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the hermitian matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the hermitian matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the hermitian * matrix and the strictly upper triangular part of A is not * referenced. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN, DBLE, DCMPLX, DCONJG * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZCOPY * .. Parameters .. DOUBLE PRECISION ZERO COMPLEX*16 ZZERO, ZONE PARAMETER ( ZERO = 0.0D+0, $ ZZERO = ( 0.0D+0, 0.0D+0 ), $ ZONE = ( 1.0D+0, 0.0D+0 ) ) * .. User specified parameters for ZHEMM .. INTEGER RCB, CB PARAMETER ( RCB = 80, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZHEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZZERO ).AND.( BETA.EQ.ZONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZZERO )THEN CALL ZGEMM ( 'N', 'N', M, N, 0, ZZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 60, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 20, I = 1, ISEC T1( I, I ) = DCMPLX( DBLE( T1( I, I ) ), ZERO ) 20 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly upper triangular diagonal block of A is copied * to the strictly lower triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 50, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 40, J = JJ+1, II+ISEC-1 DO 30, I = JJ, J-1 T1( J-II+1, I-II+1 ) = DCONJG( A( I, J ) ) 30 CONTINUE 40 CONTINUE 50 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*conjg( A' )*B + C and C := alpha*A*B + C, * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL ZGEMM ( 'C', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ZONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ZONE, C( II, 1 ), LDC ) END IF 60 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 120, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 70, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 70 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 80, I = 1, ISEC T1( I, I ) = DCMPLX( DBLE( T1( I, I ) ), ZERO ) 80 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly lower triangular diagonal block of A is copied * to the strictly upper triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 110, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 100, J = II, JJ+JSEC-2 DO 90, I = J+1, II+ISEC-1 T1( J-II+1, I-II+1 ) = DCONJG( A( I, J ) ) 90 CONTINUE 100 CONTINUE 110 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*conjg( A' )*B + C and C := alpha*A*B + C, * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'C', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ZONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ZONE, C( II, 1 ), LDC ) END IF 120 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 180, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 130 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 140, J = 1, JSEC T1( J, J ) = DCMPLX( DBLE( T1( J, J ) ), ZERO ) 140 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly upper triangular diagonal block of A is copied * to the strictly lower triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 170, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 160, I = II+1, JJ+JSEC-1 DO 150, J = II, I-1 T1( I-JJ+1, J-JJ+1 ) = DCONJG( A( J, I ) ) 150 CONTINUE 160 CONTINUE 170 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*conjg( A' ) + C, * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ZONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'C', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ZONE, C( 1, JJ ), LDC ) END IF 180 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 240, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 190, J = JJ, JJ+JSEC-1 CALL ZCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 190 CONTINUE * * Set the imaginary part of diagonal elements of T1 * to zero. * DO 200, J = 1, JSEC T1( J, J ) = DCMPLX( DBLE( T1( J, J ) ), ZERO ) 200 CONTINUE * * T1 := conjg( A' ), the conjugated transpose of a * strictly lower triangular diagonal block of A is copied * to the strictly upper triangular part of T1. Notice that * T1 is referenced by row and that the maximum length of a * vector referenced is CB. * DO 230, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 220, I = JJ, II+ISEC-2 DO 210, J = I+1, JJ+JSEC-1 T1( I-JJ+1, J-JJ+1 ) = DCONJG( A( J, I ) ) 210 CONTINUE 220 CONTINUE 230 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*conjg( A' ) + C, * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ZONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'C', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ZONE, C( 1, JJ ), LDC ) END IF 240 CONTINUE END IF END IF * RETURN * * End of ZHEMM. * END SHAR_EOF fi # end of overwriting check if test -f 'zher2k.f' then echo shar: will not over-write existing file "'zher2k.f'" else cat << SHAR_EOF > 'zher2k.f' SUBROUTINE ZHER2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC DOUBLE PRECISION BETA COMPLEX*16 ALPHA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZHER2K performs one of the hermitian rank 2k operations * * C := alpha*A*conjg( B' ) + conjg( alpha )*B*conjg( A' ) + beta*C, * * or * * C := alpha*conjg( A' )*B + conjg( alpha )*conjg( B' )*A + beta*C, * * where alpha and beta are scalars with beta real, C is an n by n * hermitian matrix and A and B are n by k matrices in the first case * and k by n matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*conjg( B' ) + * conjg( alpha )*B*conjg( A' ) + * beta*C. * * TRANS = 'C' or 'c' C := alpha*conjg( A' )*B + * conjg( alpha )*conjg( B' )*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'C' or 'c', K specifies the number of rows of the * matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC LOGICAL UPPER, NOTR COMPLEX*16 ZBETA * .. Intrinsic Functions .. INTRINSIC MIN, MAX, DBLE, DCMPLX, DCONJG * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZAXPY, ZSCAL * .. Parameters .. DOUBLE PRECISION ONE, ZERO COMPLEX*16 ZONE, ZZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ ZONE = ( 1.0D+0, 0.0D+0 ), $ ZZERO = ( 0.0D+0, 0.0D+0 ) ) * .. User specified parameters for ZHER2K .. INTEGER RCB, CB PARAMETER ( RCB = 80, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZHER2K', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * ZBETA = DCMPLX( BETA, ZERO ) * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN C( 1, 1 ) = DCMPLX( BETA*DBLE( C( 1, 1 ) ), ZERO ) DO 10, I = 2, N CALL ZSCAL ( I-1, ZBETA, C( 1, I ), 1 ) C( I, I ) = DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) 10 CONTINUE ELSE DO 20, I = 1, N-1 C( I, I ) = DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) CALL ZSCAL ( N-I, ZBETA, C( I+1, I ), 1 ) 20 CONTINUE C( N, N ) = DCMPLX( BETA*DBLE( C( N, N ) ), ZERO ) END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*conjg( B' ) + * conjg( alpha )*B*conjg( A' ) + beta*C. Upper, Notr. * DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL ZGEMM ( 'N', 'C', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, ZBETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL ZAXPY ( I-II+1, ZONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * lower triangular part of T1 is added to the upper * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by ZAXPY is CB. * DO 70, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 60, I = JJ, II+ISEC-1 DO 50, J = JJ, MIN( JJ+JSEC-1, I ) C( J, I ) = C( J, I ) + $ DCONJG( T1( I-II+1, J-II+1 ) ) 50 CONTINUE 60 CONTINUE 70 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 80, I = II, II+ISEC-1 C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 80 CONTINUE * * C := alpha*A*conjg( B' ) + beta*C and * C := conjg( alpha )*B*conjg( A' ) + C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'C', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, ZBETA, $ C( 1, II ), LDC ) CALL ZGEMM ( 'N', 'C', II-1, ISEC, K, DCONJG( ALPHA ), $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ZONE, $ C( 1, II ), LDC ) END IF 90 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B + * conjg( alpha )*conjg( B' )*A + beta*C. Upper, Trans. * DO 160, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*conjg( A' )*B, matrix multiply on * rectangular blocks of A and B. T1 is a square block. * CALL ZGEMM ( 'C', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 100, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, ZBETA, C( II, I ), 1 ) 100 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 110, I = II, II+ISEC-1 CALL ZAXPY ( I-II+1, ZONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 110 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * lower triangular part of T1 is added to the upper * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by ZAXPY is CB. * DO 140, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 130, I = JJ, II+ISEC-1 DO 120, J = JJ, MIN( JJ+JSEC-1, I ) C( J, I ) = C( J, I ) + $ DCONJG( T1( I-II+1, J-II+1 ) ) 120 CONTINUE 130 CONTINUE 140 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 150, I = II, II+ISEC-1 C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 150 CONTINUE * * C := alpha*conjg( A' )*B + beta*C and * C := alpha*conjg( B' )*A + C, matrix multiply on upper * vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'C', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, ZBETA, $ C( 1, II ), LDC ) CALL ZGEMM ( 'C', 'N', II-1, ISEC, K, DCONJG( ALPHA ), $ B( 1, 1 ), LDB, A( 1, II ), LDA, ZONE, $ C( 1, II ), LDC ) END IF 160 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*conjg( B' ) + * alpha*B*conjg( A' ) + beta*C. Lower, Notr. * DO 230, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL ZGEMM ( 'N', 'C', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 170, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, ZBETA, C( I, I ), 1 ) 170 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 180, I = II, II+ISEC-1 CALL ZAXPY ( II+ISEC-I, ZONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 180 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * upper triangular part of T1 is added to the lower * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by ZAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 DO 190, J = MAX( JJ, I), JJ+JSEC-1 C( J, I ) = C( J, I ) + $ DCONJG( T1( I-II+1, J-II+1 ) ) 190 CONTINUE 200 CONTINUE 210 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 220, I = II, II+ISEC-1 C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 220 CONTINUE * * C := alpha*A*conjg( B' ) + beta*C and * C := alpha*B*conjg( A' ) + C, matrix multiply on lower * vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ ZBETA, C( II+ISEC, II ), LDC ) CALL ZGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ DCONJG( ALPHA ), B( II+ISEC, 1 ), LDB, A( II, 1 ), $ LDA, ZONE, C( II+ISEC, II ), LDC ) END IF 230 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B + * alpha*conjg( B' )*A + beta*C. Lower, Trans. * DO 300, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*conjg( B' ), matrix multiply on rectangular * blocks of A and B. T1 is a square block. * CALL ZGEMM ( 'C', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 240, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, ZBETA, C( I, I ), 1 ) 240 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 250, I = II, II+ISEC-1 CALL ZAXPY ( II+ISEC-I, ZONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 250 CONTINUE * * C := conjg( T1' ) + C, the conjugated transpose of the * upper triangular part of T1 is added to the lower * triangular diagonal block of C. Notice that T1 is * referenced by row and that the maximum length of a vector * referenced by ZAXPY is CB. * DO 280, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 270, I = II, JJ+JSEC-1 DO 260, J = MAX( JJ, I), JJ+JSEC-1 C( J, I ) = C( J, I ) + $ DCONJG( T1( I-II+1, J-II+1 ) ) 260 CONTINUE 270 CONTINUE 280 CONTINUE * * Set the imaginary part of diagonal elements of C * to zero. * DO 290, I = II, II+ISEC-1 C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 290 CONTINUE * * C := alpha*conjg( A' )*B + beta*C and * C := alpha*conjg( B' )*A + C, matrix multiply on lower * vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ ZBETA, C( II+ISEC, II ), LDC ) CALL ZGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ DCONJG( ALPHA ), B( 1, II+ISEC ), LDB, A( 1, II ), $ LDA, ZONE, C( II+ISEC, II ), LDC ) END IF 300 CONTINUE END IF END IF * RETURN * * End of ZHER2K. * END SHAR_EOF fi # end of overwriting check if test -f 'zherk.f' then echo shar: will not over-write existing file "'zherk.f'" else cat << SHAR_EOF > 'zherk.f' SUBROUTINE ZHERK ( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZHERK performs one of the hermitian rank k operations * * C := alpha*A*conjg( A' ) + beta*C, * * or * * C := alpha*conjg( A' )*A + beta*C, * * where alpha and beta are real scalars, C is an n by n hermitian * matrix and A is an n by k matrix in the first case and a k by n * matrix in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*conjg( A' ) + beta*C. * * TRANS = 'C' or 'c' C := alpha*conjg( A' )*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'C' or 'c', K specifies the number of rows of the * matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK COMPLEX*16 ZALPHA, ZBETA, ZDELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX, DBLE, DCMPLX, DCONJG * .. External Functions .. LOGICAL LSAME, ZBIGP, ZCLD EXTERNAL LSAME, ZBIGP, ZCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZGEMV, ZHER, ZCOPY, ZSCAL * .. Parameters .. DOUBLE PRECISION ONE, ZERO COMPLEX*16 ZONE INTEGER ZIP51, ZIP52 PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, $ ZONE = ( 1.0D+0, 0.0D+0 ), $ ZIP51 = 51, ZIP52 = 52 ) * .. User specified parameters for ZHERK .. INTEGER RB, CB, RCB PARAMETER ( RCB = 44, RB = 44, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ), $ T4( CB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND.( .NOT.LSAME( TRANS, 'C' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZHERK ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * ZALPHA = DCMPLX( ALPHA, ZERO ) ZBETA = DCMPLX( BETA, ZERO ) * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN C( 1, 1 ) = DCMPLX( BETA*DBLE( C( 1, 1 ) ), ZERO ) DO 10, I = 2, N CALL ZSCAL ( I-1, ZBETA, C( 1, I ), 1 ) C( I, I ) = DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) 10 CONTINUE ELSE DO 20, I = 1, N-1 C( I, I ) = DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) CALL ZSCAL ( N-I, ZBETA, C( I+1, I ), 1 ) 20 CONTINUE C( N, N ) = DCMPLX( BETA*DBLE( C( N, N ) ), ZERO ) END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*conjg( A' ) + beta*C. Upper, Notr. * SMALLN = .NOT.ZBIGP( ZIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZBIGP( ZIP52 , N, K ) DO 90, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'C', II-1, ISEC, K, ZALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ ZBETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN C( II, II ) = $ DCMPLX( BETA*DBLE( C( II, II ) ), ZERO ) DO 30, I = II+1, II+ISEC-1 CALL ZSCAL ( I-II, ZBETA, C( II, I ), 1 ) C( I, I ) = $ DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) 30 CONTINUE END IF * * C := alpha*A*conjg( A' ) + C, hermitian matrix * multiply. C is a hermitian diagonal block having * upper triangular storage format. * DO 40, L = 1, K CALL ZHER ( 'U', ISEC, ALPHA, A( II, L ), $ 1, C( II, II ), LDC ) 40 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * hermitian matrix C is copied to the upper * triangular part of T2. * DO 50, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 50 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. The imaginary part of the * diagonal elements of T2 are set to ZERO. * IF( BETA.NE.ONE )THEN T2( 1, 1 ) = $ DCMPLX( BETA*DBLE( T2( 1, 1 ) ), ZERO ) DO 60, I = 2, ISEC CALL ZSCAL ( I-1, ZBETA, T2( 1, I ), 1 ) T2( I, I ) = $ DCMPLX( BETA*DBLE( T2( I, I ) ), ZERO ) 60 CONTINUE END IF * * T2 := alpha*A*conjg( A' ) + T2, hermitian matrix * multiply. T2 contains a hermitian block having * upper triangular storage format. * DO 70, L = 1, K CALL ZHER ( 'U', ISEC, ALPHA, A( II, L ), $ 1, T2( 1, 1 ), RCB ) 70 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 80, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 80 CONTINUE END IF 90 CONTINUE ELSE DO 140, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'C', II-1, ISEC, K, ZALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ ZBETA, C( 1, II ), LDC ) END IF ZDELTA = ZBETA DO 130, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 100, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 100 CONTINUE * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 120, I = II, II+ISEC-1 DO 110, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ DCONJG( T1( I-II+1, L-LL+1 ) ) 110 CONTINUE CALL ZGEMV ( 'N', I-II+1, LSEC, ZALPHA, $ T1( 1, 1 ), RB, T4( 1 ), 1, $ ZDELTA, C( II, I ), 1 ) C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 120 CONTINUE ZDELTA = ZONE 130 CONTINUE 140 CONTINUE END IF ELSE * * Form C := alpha*conjg( A' )*A + beta*C. Upper, Trans. * SMALLN = .NOT.ZBIGP( ZIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZBIGP( ZIP52 , N, K ) DO 250, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'C', 'N', II-1, ISEC, K, ZALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ ZBETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN C( II, II ) = $ DCMPLX( BETA*DBLE( C( II, II ) ), ZERO ) DO 150, I = II+1, II+ISEC-1 CALL ZSCAL ( I-II, ZBETA, C( II, I ), 1 ) C( I, I ) = $ DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) 150 CONTINUE END IF * * C := alpha*conjg( A' )*A + C, hermitian matrix * multiply. C is a hermitian diagonal block having * upper triangular storage format. The local array * T3 is used for temporary storage of the conjugate * transposed vectors of A. * DO 170, L = 1, K DO 160, I = II, II+ISEC-1 T3( I-II+1, 1 ) = DCONJG( A( L, I ) ) 160 CONTINUE CALL ZHER ( 'U', ISEC, ALPHA, T3( 1, 1 ), $ 1, C( II, II ), LDC ) 170 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * hermitian matrix C is copied to the upper * triangular part of T2. * DO 180, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 180 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 190, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, ZBETA, $ T2( 1, I-II+1 ), 1 ) 190 CONTINUE END IF DO 230, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 200, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 200 CONTINUE * * T2 := alpha*conjg( T3' )*T3 + T2, hermitian * matrix multiply. T2 contains a hermitian block * having upper triangular storage format. The * local array T3 is used for temporary storage of * the conjugate transposed vectors of A. * DO 220, L = LL, LL+LSEC-1 DO 210, I = 1, ISEC T3( I, L-LL+1 ) = $ DCONJG( T3( I, L-LL+1 ) ) 210 CONTINUE CALL ZHER ( 'U', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 220 CONTINUE 230 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 240, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 240 CONTINUE END IF 250 CONTINUE ELSE CLDA = ZCLD( LDA ) DO 330, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'C', 'N', II-1, ISEC, K, ZALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ ZBETA, C( 1, II ), LDC ) END IF ZDELTA = ZBETA DO 320, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := conjg( A' ), the conjugated transpose of a * rectangular block of A is copied to T1. * IF( CLDA )THEN DO 270, I = II, II+ISEC-1 DO 260, L = LL, LL+LSEC-1 T1( I-II+1, L-LL+1 ) = $ DCONJG( A( L, I ) ) 260 CONTINUE 270 CONTINUE ELSE DO 290, L = LL, LL+LSEC-1 DO 280, I = II, II+ISEC-1 T1( I-II+1, L-LL+1 ) = $ DCONJG( A( L, I ) ) 280 CONTINUE 290 CONTINUE END IF * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 310, I = II, II+ISEC-1 DO 300, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ DCONJG( T1( I-II+1, L-LL+1 ) ) 300 CONTINUE CALL ZGEMV ( 'N', I-II+1, LSEC, ZALPHA, $ T1( 1, 1 ), RB, T4( 1 ), 1, $ ZDELTA, C( II, I ), 1 ) C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 310 CONTINUE ZDELTA = ZONE 320 CONTINUE 330 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*conjg( A' ) + beta*C. Lower, Notr. * SMALLN = .NOT.ZBIGP( ZIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZBIGP( ZIP52 , N, K ) DO 400, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 340, I = II, II+ISEC-2 C( I, I ) = $ DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) CALL ZSCAL ( II+ISEC-I-1, ZBETA, $ C( I+1, I ), 1 ) 340 CONTINUE C( II+ISEC-1, II+ISEC-1 ) = $ DCMPLX( BETA*DBLE( C( II+ISEC-1, $ II+ISEC-1 ) ), ZERO ) END IF * * C := alpha*A*conjg( A' ) + C, hermitian matrix * multiply. C is a hermitian diagonal block having * lower triangular storage format. * DO 350, L = 1, K CALL ZHER ( 'L', ISEC, ALPHA, A( II, L ), $ 1, C( II, II ), LDC ) 350 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * hermitian matrix C is copied to the lower * triangular part of T2. * DO 360, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 360 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. The imaginary part of the * diagonal elements of T2 are set to ZERO. * IF( BETA.NE.ONE )THEN DO 370, I = 1, ISEC-1 T2( I, I ) = $ DCMPLX( BETA*DBLE( T2( I, I ) ), ZERO ) CALL ZSCAL ( ISEC-I, ZBETA, $ T2( I+1, I ), 1 ) 370 CONTINUE T2( ISEC, ISEC ) = $ DCMPLX( BETA*DBLE( T2( ISEC, ISEC ) ), $ ZERO ) END IF * * T2 := alpha*A*conjg( A' ) + T2, symmetric matrix * multiply. T2 contains a hermitian block having * lower triangular storage format. * DO 380, L = 1, K CALL ZHER ( 'L', ISEC, ALPHA, A( II, L ), $ 1, T2( 1, 1 ), RCB ) 380 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 390, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ ZALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, ZBETA, C( II+ISEC, II ), LDC ) END IF 400 CONTINUE ELSE DO 450, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 ZDELTA = ZBETA DO 440, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 410, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 410 CONTINUE * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 430, I = II, II+ISEC-1 DO 420, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ DCONJG( T1( I-II+1, L-LL+1 ) ) 420 CONTINUE CALL ZGEMV ( 'N', II+ISEC-I, LSEC, ZALPHA, $ T1( I-II+1, 1 ), RB, T4( 1 ), 1, $ ZDELTA, C( I, I ), 1 ) C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 430 CONTINUE ZDELTA = ZONE 440 CONTINUE * * C := alpha*A*conjg( A' ) + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'C', N-II-ISEC+1, ISEC, K, $ ZALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, ZBETA, C( II+ISEC, II ), LDC ) END IF 450 CONTINUE END IF ELSE * * Form C := alpha*conjg( A' )*A + beta*C. Lower, Trans. * SMALLN = .NOT.ZBIGP( ZIP51 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZBIGP( ZIP52 , N, K ) DO 560, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. The imaginary part of * the diagonal elements of C are set to ZERO. * IF( BETA.NE.ONE )THEN DO 460, I = II, II+ISEC-2 C( I, I ) = $ DCMPLX( BETA*DBLE( C( I, I ) ), ZERO ) CALL ZSCAL ( II+ISEC-I-1, ZBETA, $ C( I+1, I ), 1 ) 460 CONTINUE C( II+ISEC-1, II+ISEC-1 ) = $ DCMPLX( BETA*DBLE( C( II+ISEC-1, $ II+ISEC-1 ) ), ZERO ) END IF * * C := alpha*conjg( A' )*A + C, hermitian matrix * multiply. C is a hermitian diagonal block having * lower triangular storage format. The local array * T3 is used for temporary storage of the conjugate * transposed vectors of A. * DO 480, L = 1, K DO 470, I = II, II+ISEC-1 T3( I-II+1, 1 ) = DCONJG( A( L, I ) ) 470 CONTINUE CALL ZHER ( 'L', ISEC, ALPHA, T3( 1, 1 ), $ 1, C( II, II ), LDC ) 480 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 490, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 490 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 500, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, ZBETA, $ T2( I-II+1, I-II+1 ), 1 ) 500 CONTINUE END IF DO 540, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 510, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 510 CONTINUE * * T2 := alpha*conjg( T3' )*T3 + T2, hermitian * matrix multiply. T2 contains a hermitian block * having lower triangular storage format. The * local array T3 is used for temporary storage of * the conjugate transposed vectors of A. * DO 530, L = LL, LL+LSEC-1 DO 520, I = 1, ISEC T3( I, L-LL+1 ) = $ DCONJG( T3( I, L-LL+1 ) ) 520 CONTINUE CALL ZHER ( 'L', ISEC, ALPHA, $ T3( 1, L-LL+1 ), 1, T2( 1, 1 ), RCB ) 530 CONTINUE 540 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 550, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 550 CONTINUE END IF * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ ZALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, ZBETA, C( II+ISEC, II ), LDC ) END IF 560 CONTINUE ELSE CLDA = ZCLD( LDA ) DO 650, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 ZDELTA = ZBETA DO 640, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := conjg( A' ), the conjugated transpose of a * rectangular block of A is copied to T1. * IF( CLDA )THEN DO 580, I = II, II+ISEC-1 DO 570, L = LL, LL+LSEC-1 T1( I-II+1, L-LL+1 ) = $ DCONJG( A( L, I ) ) 570 CONTINUE 580 CONTINUE ELSE DO 600, L = LL, LL+LSEC-1 DO 590, I = II, II+ISEC-1 T1( I-II+1, L-LL+1 ) = $ DCONJG( A( L, I ) ) 590 CONTINUE 600 CONTINUE END IF * * C := alpha*T1*conjg( T1' ) + delta*C, C is * hermitian having triangular storage format. Delta * is used instead of beta to avoid updating the * block of C with beta multiple times. The local * array T4 is used for the conjugated transpose * of vectors of T1. * DO 630, I = II, II+ISEC-1 DO 620, L = LL, LL+LSEC-1 T4( L-LL+1 ) = $ DCONJG( T1( I-II+1, L-LL+1 ) ) 620 CONTINUE CALL ZGEMV ( 'N', II+ISEC-I, LSEC, ZALPHA, $ T1( I-II+1, 1 ), RB, T4( 1 ), 1, $ ZDELTA, C( I, I ), 1 ) C( I, I ) = DCMPLX( DBLE( C( I, I ) ), ZERO ) 630 CONTINUE ZDELTA = ZONE 640 CONTINUE * * C := alpha*conjg( A' )*A + beta*C, matrix multiply * updating lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'C', 'N', N-II-ISEC+1, ISEC, K, $ ZALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, ZBETA, C( II+ISEC, II ), LDC ) END IF 650 CONTINUE END IF END IF END IF * RETURN * * End of ZHERK. * END SHAR_EOF fi # end of overwriting check if test -f 'zsgpm.f' then echo shar: will not over-write existing file "'zsgpm.f'" else cat << SHAR_EOF > 'zsgpm.f' PROGRAM ZSGPM * * ZSGPM re-writes GEMM-Based Level 3 BLAS source files replacing lines * containing old PARAMETER statements for user specified parameters, * with lines containing new PARAMETER statements given in an input * file. The user can conveniently assign new values to the PARAMETER * statements in the input file, and then run ZSGPM to distribute these * values to the GEMM-based routines. An input file consists of three * different types of lines, except for empty lines. * * o Comment lines starting with the character '*'. * * o Lines containing single file-names for GEMM-based source files. * * o Lines containing PARAMETER statements that replaces the * corresponding lines in the GEMM-based routines. * * The lines with single filenames are followed by lines containing the * new PARAMETER statements for that particular file (see the input file * 'dgpm.in'). Read the file INSTALL for further instructions. * * * -- Written in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER I, IB, IE, JB, JE, KB, KE, NAM, NXTLN LOGICAL PMEOF * .. External Functions .. LOGICAL LNCMP, GETWRD INTEGER EOLN EXTERNAL LNCMP, GETWRD, EOLN * .. Parameters .. INTEGER NPM, NGB, NTMP, NERR PARAMETER ( NPM = 5, NERR = 6, NGB = 10, NTMP = 12 ) INTEGER NLNS, LLN PARAMETER ( NLNS = 14, LLN = 256 ) CHARACTER TMPNAM*( LLN ) PARAMETER ( TMPNAM = 'tmpgb.tmp' ) * .. Local Arrays .. CHARACTER PMLN*( LLN ), GBLN*( LLN ), GBNAM*( LLN ), $ STRS( NLNS, 2 )*( LLN ) CHARACTER PMLNA( LLN ), GBLNA( LLN ), GBNAMA( LLN ), $ STRSA( LLN, NLNS, 2 ) EQUIVALENCE ( PMLN, PMLNA ), ( GBLN, GBLNA ), $ ( GBNAM, GBNAMA ), ( STRS, STRSA ) * .. Data statements .. DATA STRS/ $'zsymm.f' ,'zhemm.f' ,'zsyrk.f' ,'zherk.f' , $'zsyr2k.f' ,'zher2k.f' ,'ztrmm.f' ,'ztrsm.f' , $'zbigp.f' ,' ',' ',' ', $'zcld.f' ,' ', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( RCB = $$ , RB = $$ , CB = $$ )', $'PARAMETER ( ZIP41 = $$ , ZIP42 = $$ ,', $'$ ZIP51 = $$ , ZIP52 = $$ ,', $'$ ZIP81 = $$ , ZIP82 = $$ , ZIP83 = $$ ,', $'$ ZIP91 = $$ , ZIP92 = $$ , ZIP93 = $$ )', $'PARAMETER ( LNSZ = $$ , NPRT = $$ , PRTSZ = $$ ,', $'$ LOLIM = $$ , ZP = $$ )' / * .. * .. Executable Statements .. * * Read the next non-blank/non-comment line from the input parameter * file. * 10 READ( NPM, FMT = 9000, END = 110 ) GBNAM IF( .NOT.GETWRD( GBNAMA, LLN, IB, IE ).OR. $ ( GBNAM( 1:1 ).EQ.'*' ) )THEN GO TO 10 END IF * * Check if the first word on the line is the name of a file that is * due to be changed. * 20 NAM = -1 PMEOF = .FALSE. DO 30, I = 1, NLNS IF( GBNAM( IB:IE ).EQ.STRS( I, 1 ) )THEN NAM = I END IF 30 CONTINUE IF( NAM.EQ.-1 )THEN WRITE( NERR, FMT = * )'Unknown routine name: ', GBNAM( IB:IE ) STOP END IF * * Read the next non-blank/non-comment line from the input parameter * file. * 40 READ( NPM, FMT = 9000, END = 110 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 40 END IF * * Copy each line of the GEMM-Based file, except for the lines that * are due to be changed, to the temporary file TMPNAM. Copy the * lines that should be changed from the input parameter file. Check * that the lines in the parameter file are correct compared to STRS. * NXTLN = NAM IF( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN OPEN( NGB, FILE = GBNAM( IB:IE ), STATUS = 'OLD' ) OPEN( NTMP, FILE = TMPNAM, STATUS = 'NEW' ) 50 READ( NGB, FMT = 9000, END = 80 ) GBLN IF( LNCMP( GBLNA, LLN, STRSA( 1, NXTLN, 2 ), LLN ) )THEN WRITE( NTMP, FMT = 9010 ) PMLN( 1:EOLN( PMLNA, LLN ) ) 60 READ( NPM, FMT = 9000, END = 70 ) PMLN IF( .NOT.GETWRD( PMLNA, LLN, JB, JE ).OR. $ ( PMLN( 1:1 ).EQ.'*' ) )THEN GO TO 60 END IF IF( .NOT.GETWRD( STRSA( 1, NXTLN+1, 1 ), LLN, KB, KE ).AND. $ ( LNCMP( PMLNA, LLN, STRSA( 1, NXTLN+1, 2 ), LLN ) ) $ )THEN NXTLN = NXTLN + 1 END IF ELSE WRITE( NTMP, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) END IF GO TO 50 70 PMEOF = .TRUE. GO TO 50 80 CLOSE( NGB, STATUS = 'DELETE' ) CLOSE( NTMP, STATUS = 'KEEP' ) ELSE WRITE( NERR, FMT = * )'Error in parameter file: ' WRITE( NERR, FMT = * ) PMLN STOP END IF * * Write back the temporary file TMPNAM to the GEMM-Based file and * remove the temporary file. * OPEN( NTMP, FILE = TMPNAM, STATUS = 'OLD' ) OPEN( NGB, FILE = GBNAM( IB:IE ), STATUS = 'NEW' ) 90 READ( NTMP, FMT = 9000, END = 100 ) GBLN WRITE( NGB, FMT = 9010 ) GBLN( 1:EOLN( GBLNA, LLN ) ) GO TO 90 100 CONTINUE CLOSE( NTMP, STATUS = 'DELETE' ) CLOSE( NGB, STATUS = 'KEEP' ) GBNAM = PMLN IB = JB IE = JE * IF( .NOT.PMEOF )THEN GO TO 20 END IF 110 CONTINUE * STOP * 9000 FORMAT( A ) 9010 FORMAT( A ) * * End of DSGPM. * END LOGICAL FUNCTION LNCMP( LN1, LEN1, LN2, LEN2 ) * .. Scalar Arguments .. INTEGER LEN1, LEN2 * .. Array Arguments .. CHARACTER LN1( LEN1 ), LN2( LEN2 ) * * Compare the character strings LN1 and LN2. Return .TRUE. if the * strings are identical except from wild cards ($$) corresponding * to positive integers and except from a different number of * consecutive blanks between tokens. * * * -- Written in December-1993. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER I, J LOGICAL MATCH * .. Intrinsic Functions .. INTRINSIC LGE, LLE LOGICAL LGE, LLE * .. * .. Executable Statements .. * * Find the beginning of the next tokens in LN1 and LN2. * I = 1 J = 1 10 IF( ( LN1( I ).EQ.' ' ).AND.( I.LT.LEN1 ) )THEN I = I + 1 GO TO 10 END IF 20 IF( ( LN2( J ).EQ.' ' ).AND.( J.LT.LEN2 ) )THEN J = J + 1 GO TO 20 END IF * * Compare the tokens. * IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.LT.LEN1 ).AND. $ ( J.LT.LEN2 ) )THEN I = I + 1 J = J + 1 GO TO 10 ELSE IF( ( LN1( I ).EQ.LN2( J ) ).AND.( I.EQ.LEN1 ).AND. $ ( J.EQ.LEN2 ) )THEN LNCMP = .TRUE. RETURN ELSE IF( ( I.EQ.LEN1 ).AND.( J.EQ.LEN2 ) )THEN LNCMP = .FALSE. RETURN ELSE IF( LN1( I ).EQ.'$' )THEN IF( I.LT.LEN1-1 )THEN IF( LN1( I+1 ).EQ.'$' )THEN I = I + 2 MATCH = .FALSE. 30 IF( ( LGE( LN2( J ), '0' ).AND.LLE( LN2( J ), '9' ) ) $ .AND.( J.LT.LEN2 ) )THEN J = J + 1 MATCH = .TRUE. GO TO 30 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 ELSE IF( LN2( J ).EQ.'$' )THEN IF( J.LT.LEN2-1 )THEN IF( LN2( J+1 ).EQ.'$' )THEN J = J + 2 MATCH = .FALSE. 40 IF( ( LGE( LN1( I ), '0' ).AND.LLE( LN1( I ), '9' ) ) $ .AND.( I.LT.LEN1 ) )THEN I = I + 1 MATCH = .TRUE. GO TO 40 ELSE IF( .NOT.MATCH )THEN LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF ELSE LNCMP = .FALSE. RETURN END IF GO TO 10 END IF * LNCMP = .FALSE. RETURN * * End of LNCMP. * END SHAR_EOF fi # end of overwriting check if test -f 'zsymm.f' then echo shar: will not over-write existing file "'zsymm.f'" else cat << SHAR_EOF > 'zsymm.f' SUBROUTINE ZSYMM ( SIDE, UPLO, M, N, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO INTEGER M, N, LDA, LDB, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZSYMM performs one of the matrix-matrix operations * * C := alpha*A*B + beta*C, * * or * * C := alpha*B*A + beta*C, * * where alpha and beta are scalars, A is a symmetric matrix and B and * C are m by n matrices. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether the symmetric matrix A * appears on the left or right in the operation as follows: * * SIDE = 'L' or 'l' C := alpha*A*B + beta*C, * * SIDE = 'R' or 'r' C := alpha*B*A + beta*C, * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the symmetric matrix A is to be * referenced as follows: * * UPLO = 'U' or 'u' Only the upper triangular part of the * symmetric matrix is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of the * symmetric matrix is to be referenced. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix C. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix C. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * m when SIDE = 'L' or 'l' and is n otherwise. * Before entry with SIDE = 'L' or 'l', the m by m part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading m by m upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading m by m lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Before entry with SIDE = 'R' or 'r', the n by n part of * the array A must contain the symmetric matrix, such that * when UPLO = 'U' or 'u', the leading n by n upper triangular * part of the array A must contain the upper triangular part * of the symmetric matrix and the strictly lower triangular * part of A is not referenced, and when UPLO = 'L' or 'l', * the leading n by n lower triangular part of the array A * must contain the lower triangular part of the symmetric * matrix and the strictly upper triangular part of A is not * referenced. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, n ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, n ). * Before entry, the leading m by n part of the array B must * contain the matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. LDB must be at least * max( 1, m ). * Unchanged on exit. * * BETA - COMPLEX*16. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n updated * matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA LOGICAL LSIDE, UPPER INTEGER I, II, IX, ISEC, J, JJ, JX, JSEC * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZCOPY * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ) ) * .. User specified parameters for ZSYMM .. INTEGER RCB, CB PARAMETER ( RCB = 80, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( M.LT.0 )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, M ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZSYMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL ZGEMM ( 'N', 'N', M, N, 0, ZERO, A, MAX( LDA, LDB ), $ B, MAX( LDA, LDB ), BETA, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN * * Form C := alpha*A*B + beta*C. Left, Upper. * DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 10, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, A( II, I ), 1, T1( 1, I-II+1 ), $ 1 ) 10 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by ZCOPY is CB. * DO 30, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 20, J = JJ+1, II+ISEC-1 CALL ZCOPY ( MIN( JSEC, J-JJ ), A( JJ, J ), 1, $ T1( J-II+1, JJ-II+1 ), RCB ) 20 CONTINUE 30 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II.GT.1 )THEN CALL ZGEMM ( 'T', 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II, II+ISEC ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE * * Form C := alpha*A*B + beta*C. Left, Lower. * DO 80, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 50, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, A( I, I ), 1, $ T1( I-II+1, I-II+1 ), 1 ) 50 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by ZCOPY is CB. * DO 70, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 60, J = II, JJ+JSEC-2 CALL ZCOPY ( MIN( JSEC, JJ+JSEC-1-J ), $ A( MAX( JJ, J+1 ), J ), 1, $ T1( J-II+1, MAX( JJ-II+1, J-II+2 ) ), RCB ) 60 CONTINUE 70 CONTINUE * * C := alpha*T1*B + beta*C, a horizontal block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', ISEC, N, ISEC, ALPHA, T1( 1, 1 ), $ RCB, B( II, 1 ), LDB, BETA, C( II, 1 ), LDC ) * * C := alpha*A'*B + C and C := alpha*A*B + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'T', 'N', ISEC, N, M-II-ISEC+1, ALPHA, $ A( II+ISEC, II ), LDA, B( II+ISEC, 1 ), $ LDB, ONE, C( II, 1 ), LDC ) END IF IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, B( 1, 1 ), LDB, $ ONE, C( II, 1 ), LDC ) END IF 80 CONTINUE END IF ELSE IF( UPPER )THEN * * Form C := alpha*B*A + beta*C. Right, Upper. * DO 120, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * T1 := A, a upper triangular diagonal block of A is copied * to the upper triangular part of T1. * DO 90, J = JJ, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1, A( JJ, J ), 1, T1( 1, J-JJ+1 ), $ 1 ) 90 CONTINUE * * T1 := A', a strictly upper triangular diagonal block of * A is copied to the strictly lower triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by ZCOPY is CB. * DO 110, II = JJ, JJ+JSEC-1, CB ISEC = MIN( CB, JJ+JSEC-II ) DO 100, I = II+1, JJ+JSEC-1 CALL ZCOPY ( MIN( ISEC, I-II ), A( II, I ), 1, $ T1( I-JJ+1, II-JJ+1 ), RCB ) 100 CONTINUE 110 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, B( 1, JJ ), $ LDB, T1( 1, 1 ), RCB, BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'T', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ, JJ+JSEC ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF 120 CONTINUE ELSE * * Form C := alpha*B*A + beta*C. Right, Lower. * DO 160, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * T1 := A, a lower triangular diagonal block of A is copied * to the lower triangular part of T1. * DO 130, J = JJ, JJ+JSEC-1 CALL ZCOPY ( JJ+JSEC-J, A( J, J ), 1, $ T1( J-JJ+1, J-JJ+1 ), 1 ) 130 CONTINUE * * T1 := A', a strictly lower triangular diagonal block of * A is copied to the strictly upper triangular part of T1. * Notice that T1 is referenced by row and that the maximum * length of a vector referenced by ZCOPY is CB. * DO 150, IX = JJ+JSEC-1, JJ, -CB II = MAX( JJ, IX-CB+1 ) ISEC = IX-II+1 DO 140, I = JJ, II+ISEC-2 CALL ZCOPY ( MIN( ISEC, II+ISEC-1-I ), $ A( MAX( II, I+1 ), I ), 1, $ T1( I-JJ+1, MAX( II-JJ+1, I-JJ+2 ) ), RCB ) 140 CONTINUE 150 CONTINUE * * C := alpha*B*T1 + beta*C, a vertical block of C is * updated using the general matrix multiply, ZGEMM. T1 * corresponds to a full diagonal block of the matrix A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JSEC, ALPHA, $ B( 1, JJ ), LDB, T1( 1, 1 ), RCB, $ BETA, C( 1, JJ ), LDC ) * * C := alpha*B*A + C and C := alpha*B*A' + C, general * matrix multiply operations involving rectangular blocks * of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, ALPHA, $ B( 1, JJ+JSEC ), LDB, A( JJ+JSEC, JJ ), $ LDA, ONE, C( 1, JJ ), LDC ) END IF IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'T', M, JSEC, JJ-1, ALPHA, $ B( 1, 1 ), LDB, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 160 CONTINUE END IF END IF * RETURN * * End of ZSYMM. * END SHAR_EOF fi # end of overwriting check if test -f 'zsyr2k.f' then echo shar: will not over-write existing file "'zsyr2k.f'" else cat << SHAR_EOF > 'zsyr2k.f' SUBROUTINE ZSYR2K( UPLO, TRANS, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDB, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZSYR2K performs one of the symmetric rank 2k operations * * C := alpha*A*B' + alpha*B*A' + beta*C, * * or * * C := alpha*A'*B + alpha*B'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A and B are n by k matrices in the first case and k by n * matrices in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' + * beta*C. * * TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A + * beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrices A and B, and on entry with * TRANS = 'T' or 't', K specifies the number of rows of the * matrices A and B. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array B must contain the matrix B, otherwise * the leading k by n part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDB must be at least max( 1, n ), otherwise LDB must * be at least max( 1, k ). * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, JJ, JX, JSEC LOGICAL UPPER, NOTR * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZAXPY, ZSCAL * .. Parameters .. COMPLEX*16 ONE, ZERO PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. User specified parameters for ZSYR2K .. INTEGER RCB, CB PARAMETER ( RCB = 80, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTR ).AND. ( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDB.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 12 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZSYR2K', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL ZSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL ZSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Upper, Notr. * DO 70, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL ZGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 40, I = II, II+ISEC-1 CALL ZAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 40 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by ZAXPY is CB. * DO 60, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 50, I = JJ, II+ISEC-1 CALL ZAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 50 CONTINUE 60 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( II, 1 ), LDB, BETA, $ C( 1, II ), LDC ) CALL ZGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( II, 1 ), LDA, ONE, $ C( 1, II ), LDC ) END IF 70 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Upper, Trans. * DO 120, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * T1 := alpha*A'*B, general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL ZGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a upper triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 80, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, C( II, I ), 1 ) 80 CONTINUE END IF * * C := T1 + C, the upper triangular part of T1 is added to * the upper triangular diagonal block of C. * DO 90, I = II, II+ISEC-1 CALL ZAXPY ( I-II+1, ONE, T1( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 90 CONTINUE * * C := T1' + C, the transpose of the lower triangular part * of T1 is added to the upper triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by ZAXPY is CB. * DO 110, JJ = II, II+ISEC-1, CB JSEC = MIN( CB, II+ISEC-JJ ) DO 100, I = JJ, II+ISEC-1 CALL ZAXPY ( MIN( JSEC, I-JJ+1 ), ONE, $ T1( I-II+1, JJ-II+1 ), RCB, C( JJ, I ), 1 ) 100 CONTINUE 110 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, B( 1, II ), LDB, BETA, $ C( 1, II ), LDC ) CALL ZGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ B( 1, 1 ), LDB, A( 1, II ), LDA, ONE, $ C( 1, II ), LDC ) END IF 120 CONTINUE END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*B' + alpha*B*A' + beta*C. Lower, Notr. * DO 170, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL ZGEMM ( 'N', 'T', ISEC, ISEC, K, ALPHA, A( II, 1 ), $ LDA, B( II, 1 ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 130, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 130 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 140, I = II, II+ISEC-1 CALL ZAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 140 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by ZAXPY is CB. * DO 160, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 150, I = II, JJ+JSEC-1 CALL ZAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 150 CONTINUE 160 CONTINUE * * C := alpha*A*B' + beta*C and C := alpha*B*A' + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ A( II+ISEC, 1 ), LDA, B( II, 1 ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL ZGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, ALPHA, $ B( II+ISEC, 1 ), LDB, A( II, 1 ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 170 CONTINUE ELSE * * Form C := alpha*A'*B + alpha*B'*A + beta*C. Lower, Trans. * DO 220, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * T1 := alpha*A*B', general matrix multiply on rectangular * blocks of A and B. T1 is square. * CALL ZGEMM ( 'T', 'N', ISEC, ISEC, K, ALPHA, A( 1, II ), $ LDA, B( 1, II ), LDB, ZERO, T1( 1, 1 ), RCB ) * * C := beta*C, a lower triangular diagonal block of C is * updated with beta. * IF( BETA.NE.ONE )THEN DO 180, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 180 CONTINUE END IF * * C := T1 + C, the lower triangular part of T1 is added to * the lower triangular diagonal block of C. * DO 190, I = II, II+ISEC-1 CALL ZAXPY ( II+ISEC-I, ONE, T1( I-II+1, I-II+1 ), 1, $ C( I, I ), 1 ) 190 CONTINUE * * C := T1' + C, the transpose of the upper triangular part * of T1 is added to the lower triangular diagonal block * of C. Notice that T1 is referenced by row and that the * maximum length of a vector referenced by ZAXPY is CB. * DO 210, JX = II+ISEC-1, II, -CB JJ = MAX( II, JX-CB+1 ) JSEC = JX-JJ+1 DO 200, I = II, JJ+JSEC-1 CALL ZAXPY ( MIN( JSEC, JJ+JSEC-I ), ONE, $ T1( I-II+1, MAX( JJ-II+1, I-II+1 ) ), RCB, $ C( MAX( JJ, I ), I ), 1 ) 200 CONTINUE 210 CONTINUE * * C := alpha*A'*B + beta*C and C := alpha*B'*A + C, * general matrix multiply on lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ A( 1, II+ISEC ), LDA, B( 1, II ), LDB, $ BETA, C( II+ISEC, II ), LDC ) CALL ZGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, ALPHA, $ B( 1, II+ISEC ), LDB, A( 1, II ), LDA, $ ONE, C( II+ISEC, II ), LDC ) END IF 220 CONTINUE END IF END IF * RETURN * * End of ZSYR2K. * END SHAR_EOF fi # end of overwriting check if test -f 'zsyrk.f' then echo shar: will not over-write existing file "'zsyrk.f'" else cat << SHAR_EOF > 'zsyrk.f' SUBROUTINE ZSYRK ( UPLO, TRANS, N, K, ALPHA, A, LDA, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 UPLO, TRANS INTEGER N, K, LDA, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZSYRK performs one of the symmetric rank k operations * * C := alpha*A*A' + beta*C, * * or * * C := alpha*A'*A + beta*C, * * where alpha and beta are scalars, C is an n by n symmetric matrix * and A is an n by k matrix in the first case and a k by n matrix * in the second case. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array C is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of C * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of C * is to be referenced. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. * * TRANS = 'T' or 't' C := alpha*A'*A + beta*C. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry with TRANS = 'N' or 'n', K specifies the number * of columns of the matrix A, and on entry with * TRANS = 'T' or 't', K specifies the number of rows of the * matrix A. K must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANS = 'N' or 'n', and is n otherwise. * Before entry with TRANS = 'N' or 'n', the leading n by k * part of the array A must contain the matrix A, otherwise * the leading k by n part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANS = 'N' or 'n' * then LDA must be at least max( 1, n ), otherwise LDA must * be at least max( 1, k ). * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array C must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of C is not referenced. On exit, the * upper triangular part of the array C is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array C must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of C is not referenced. On exit, the * lower triangular part of the array C is overwritten by the * lower triangular part of the updated matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, n ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA INTEGER I, II, IX, ISEC, L, LL, LSEC LOGICAL UPPER, NOTR, CLDA, SMALLN, TINYK COMPLEX*16 DELTA * .. Intrinsic Functions .. INTRINSIC MIN, MAX * .. External Functions .. LOGICAL LSAME, ZBIGP, ZCLD EXTERNAL LSAME, ZBIGP, ZCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZGEMV, ZCOPY, ZSCAL * .. Parameters .. COMPLEX*16 ONE, ZERO INTEGER ZIP41, ZIP42 PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ), $ ZERO = ( 0.0D+0, 0.0D+0 ), $ ZIP41 = 41, ZIP42 = 42 ) * .. User specified parameters for ZSYRK .. INTEGER RB, CB, RCB PARAMETER ( RCB = 44, RB = 44, CB = 44 ) * .. Local Arrays .. COMPLEX*16 T1( RB, CB ), T2( RCB, RCB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANS, 'N' ) IF( NOTR )THEN NROWA = N ELSE NROWA = K END IF INFO = 0 IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO , 'L' ) ) )THEN INFO = 1 ELSE IF( ( ( .NOT.NOTR ) ).AND.( .NOT.LSAME( TRANS, 'T' ) ) )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( K.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 7 ELSE IF( LDC.LT.MAX( 1, N ) )THEN INFO = 10 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZSYRK ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero or k.eq.0. * IF( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) )THEN IF( UPPER )THEN DO 10, I = 1, N CALL ZSCAL ( I, BETA, C( 1, I ), 1 ) 10 CONTINUE ELSE DO 20, I = 1, N CALL ZSCAL ( N-I+1, BETA, C( I, I ), 1 ) 20 CONTINUE END IF RETURN END IF * * Start the operations. * IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Upper, Notr. * SMALLN = .NOT.ZBIGP( ZIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZBIGP( ZIP42 , N, K ) DO 110, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 30, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, C( II, I ), 1 ) 30 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 50, I = II, II+ISEC-1 DO 40, L = 1, K CALL ZAXPY ( I-II+1, ALPHA*A( I, L ), $ A( II, L ), 1, C( II, I ), 1 ) 40 CONTINUE 50 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 60, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 60 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 70, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having upper * triangular storage format. * DO 90, I = II, II+ISEC-1 DO 80, L = 1, K CALL ZAXPY ( I-II+1, ALPHA*A( I, L ), $ A( II, L ), 1, T2( 1, I-II+1 ), 1 ) 80 CONTINUE 90 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 100, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 100 CONTINUE END IF 110 CONTINUE ELSE DO 150, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A*A' + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'T', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( II, 1 ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 140, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 120, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 120 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 130, I = II, II+ISEC-1 CALL ZGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 130 CONTINUE DELTA = ONE 140 CONTINUE 150 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Upper, Trans. * SMALLN = .NOT.ZBIGP( ZIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZBIGP( ZIP42 , N, K ) DO 260, II = 1, N, RCB ISEC = MIN( RCB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF IF( TINYK )THEN * * C := beta*C, a upper triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 160, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, C( II, I ), 1 ) 160 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having upper * triangular storage format. * DO 180, I = II, II+ISEC-1 DO 170, L = 1, K CALL ZAXPY ( I-II+1, ALPHA*A( L, I ), $ A( L, II ), LDA, C( II, I ), 1 ) 170 CONTINUE 180 CONTINUE ELSE * * T2 := C, a upper triangular diagonal block of the * symmetric matrix C is copied to the upper * triangular part of T2. * DO 190, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, C( II, I ), 1, $ T2( 1, I-II+1 ), 1 ) 190 CONTINUE * * T2 := beta*T2, the upper triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 200, I = II, II+ISEC-1 CALL ZSCAL ( I-II+1, BETA, $ T2( 1, I-II+1 ), 1 ) 200 CONTINUE END IF DO 240, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 210, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 210 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * upper triangular storage format. * DO 230, I = II, II+ISEC-1 DO 220, L = LL, LL+LSEC-1 CALL ZAXPY ( I-II+1, $ ALPHA*T3( I-II+1, L-LL+1 ), $ T3( 1, L-LL+1 ), 1, $ T2( 1, I-II+1 ), 1 ) 220 CONTINUE 230 CONTINUE 240 CONTINUE * * C := T2, the upper triangular part of T2 is copied * back to C. * DO 250, I = II, II+ISEC-1 CALL ZCOPY ( I-II+1, T2( 1, I-II+1 ), 1, $ C( II, I ), 1 ) 250 CONTINUE END IF 260 CONTINUE ELSE CLDA = ZCLD( LDA ) DO 310, II = 1, N, RB ISEC = MIN( RB, N-II+1 ) * * C := alpha*A'*A + beta*C, general matrix multiply on * upper vertical blocks of C. * IF( II.GT.1 )THEN CALL ZGEMM ( 'T', 'N', II-1, ISEC, K, ALPHA, $ A( 1, 1 ), LDA, A( 1, II ), LDA, $ BETA, C( 1, II ), LDC ) END IF DELTA = BETA DO 300, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 270, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 270 CONTINUE ELSE DO 280, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 280 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 290, I = II, II+ISEC-1 CALL ZGEMV ( 'N', I-II+1, LSEC, ALPHA, $ T1( 1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( II, I ), 1 ) 290 CONTINUE DELTA = ONE 300 CONTINUE 310 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*A' + beta*C. Lower, Notr. * SMALLN = .NOT.ZBIGP( ZIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZBIGP( ZIP42 , N, K ) DO 400, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 320, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 320 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 340, I = II, II+ISEC-1 DO 330, L = 1, K CALL ZAXPY ( II+ISEC-I, ALPHA*A( I, L ), $ A( I, L ), 1, C( I, I ), 1 ) 330 CONTINUE 340 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 350, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 350 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 360, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 360 CONTINUE END IF * * T2 := alpha*A*A' + T2, symmetric matrix multiply. * T2 contains a symmetric block having lower * triangular storage format. * DO 380, I = II, II+ISEC-1 DO 370, L = 1, K CALL ZAXPY ( II+ISEC-I, ALPHA*A( I, L ), $ A( I, L ), 1, T2( I-II+1, I-II+1 ), 1 ) 370 CONTINUE 380 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 390, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 390 CONTINUE END IF * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 400 CONTINUE ELSE DO 440, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 430, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A, a rectangular block of A is copied to T1. * DO 410, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( II, L ), 1, $ T1( 1, L-LL+1 ), 1 ) 410 CONTINUE * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 420, I = II, II+ISEC-1 CALL ZGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 420 CONTINUE DELTA = ONE 430 CONTINUE * * C := alpha*A*A' + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'N', 'T', N-II-ISEC+1, ISEC, K, $ ALPHA, A( II+ISEC, 1 ), LDA, A( II, 1 ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 440 CONTINUE END IF ELSE * * Form C := alpha*A'*A + beta*C. Lower, Trans. * SMALLN = .NOT.ZBIGP( ZIP41 , N, K ) IF( SMALLN )THEN TINYK = .NOT.ZBIGP( ZIP42 , N, K ) DO 550, IX = N, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 IF( TINYK )THEN * * C := beta*C, a lower triangular diagonal block * of C is updated with beta. * IF( BETA.NE.ONE )THEN DO 450, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, C( I, I ), 1 ) 450 CONTINUE END IF * * C := alpha*A*A' + C, symmetric matrix multiply. * C is a symmetric diagonal block having lower * triangular storage format. * DO 470, I = II, II+ISEC-1 DO 460, L = 1, K CALL ZAXPY ( II+ISEC-I, ALPHA*A( L, I ), $ A( L, I ), LDA, C( I, I ), 1 ) 460 CONTINUE 470 CONTINUE ELSE * * T2 := C, a lower triangular diagonal block of the * symmetric matrix C is copied to the lower * triangular part of T2. * DO 480, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, C( I, I ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 480 CONTINUE * * T2 := beta*T2, the lower triangular part of T2 is * updated with beta. * IF( BETA.NE.ONE )THEN DO 490, I = II, II+ISEC-1 CALL ZSCAL ( II+ISEC-I, BETA, $ T2( I-II+1, I-II+1 ), 1 ) 490 CONTINUE END IF DO 530, LL = 1, K, RCB LSEC = MIN( RCB, K-LL+1 ) * * T3 := A', the transpose of a square block of A * is copied to T3. * DO 500, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T3( I-II+1, 1 ), RCB ) 500 CONTINUE * * T2 := alpha*T3*T3' + T2, symmetric matrix * multiply. T2 contains a symmetric block having * lower triangular storage format. * DO 520, I = II, II+ISEC-1 DO 510, L = LL, LL+LSEC-1 CALL ZAXPY ( II+ISEC-I, $ ALPHA*T3( I-II+1, L-LL+1 ), $ T3( I-II+1, L-LL+1 ), 1, $ T2( I-II+1, I-II+1 ), 1 ) 510 CONTINUE 520 CONTINUE 530 CONTINUE * * C := T2, the lower triangular part of T2 is copied * back to C. * DO 540, I = II, II+ISEC-1 CALL ZCOPY ( II+ISEC-I, T2( I-II+1, I-II+1 ), $ 1, C( I, I ), 1 ) 540 CONTINUE END IF * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 550 CONTINUE ELSE CLDA = ZCLD( LDA ) DO 600, IX = N, 1, -RB II = MAX( 1, IX-RB+1 ) ISEC = IX-II+1 DELTA = BETA DO 590, LL = 1, K, CB LSEC = MIN( CB, K-LL+1 ) * * T1 := A', the transpose of a rectangular block * of A is copied to T1. * IF( CLDA )THEN DO 560, I = II, II+ISEC-1 CALL ZCOPY ( LSEC, A( LL, I ), 1, $ T1( I-II+1, 1 ), RB ) 560 CONTINUE ELSE DO 570, L = LL, LL+LSEC-1 CALL ZCOPY ( ISEC, A( L, II ), LDA, $ T1( 1, L-LL+1 ), 1 ) 570 CONTINUE END IF * * C := alpha*T1*T1' + delta*C, C is symmetric having * triangular storage format. Delta is used instead * of beta to avoid updating the block of C with beta * multiple times. * DO 580, I = II, II+ISEC-1 CALL ZGEMV ( 'N', II+ISEC-I, LSEC, ALPHA, $ T1( I-II+1, 1 ), RB, T1( I-II+1, 1 ), RB, $ DELTA, C( I, I ), 1 ) 580 CONTINUE DELTA = ONE 590 CONTINUE * * C := alpha*A'*A + beta*C, general matrix multiply on * lower vertical blocks of C. * IF( II+ISEC.LE.N )THEN CALL ZGEMM ( 'T', 'N', N-II-ISEC+1, ISEC, K, $ ALPHA, A( 1, II+ISEC ), LDA, A( 1, II ), $ LDA, BETA, C( II+ISEC, II ), LDC ) END IF 600 CONTINUE END IF END IF END IF * RETURN * * End of ZSYRK. * END SHAR_EOF fi # end of overwriting check if test -f 'ztrmm.f' then echo shar: will not over-write existing file "'ztrmm.f'" else cat << SHAR_EOF > 'ztrmm.f' SUBROUTINE ZTRMM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC COMPLEX*16 ALPHA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZTRMM performs one of the matrix-matrix operations * * C := alpha*op( A )*C, or C := alpha*C*op( A ) * * where alpha is a scalar, C is an m by n matrix, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) multiplies C from * the left or right as follows: * * SIDE = 'L' or 'l' C := alpha*op( A )*C. * * SIDE = 'R' or 'r' C := alpha*C*op( A ). * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, and on exit is overwritten by the * transformed matrix. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOCONJ, NOUNIT, $ CLDC, SMALLN, TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC COMPLEX*16 GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD, DCONJG * .. External Functions .. LOGICAL LSAME, ZBIGP, ZCLD EXTERNAL LSAME, ZBIGP, ZCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZGEMV, ZTRMV, ZCOPY * .. Parameters .. COMPLEX*16 ZERO, ONE INTEGER ZIP81, ZIP82, ZIP83 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ), $ ZIP81 = 81, ZIP82 = 82, ZIP83 = 83 ) * .. User specified parameters for ZTRMM .. INTEGER RB, CB, RCB PARAMETER ( RCB = 44, RB = 44, CB = 44 ) COMPLEX*16 T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( ( .NOT.NOTR ).AND.( .NOT.NOCONJ ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTRMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL ZGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*A*C. Left, Upper, No transpose. * SMALLN = .NOT.ZBIGP( ZIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZBIGP( ZIP82, M, N ) DO 40, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a upper triangular diagonal block of A. * DO 10, J = 1, N CALL ZTRMV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * C := T3*C, triangular matrix multiply involving * a upper triangular diagonal block of A stored * in T3. * DO 30, J = 1, N CALL ZTRMV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 40 CONTINUE ELSE DELTA = ALPHA CLDC = ZCLD( LDC ) DO 110, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in ZGEMV that appears if the second * dimension (tsec) is zero. * DO 80, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE * * C := alpha*A*C + C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II, II+ISEC ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 110 CONTINUE END IF ELSE * * Form C := alpha*A'*C or C := alpha*conjg( A' )*C. * Left, Upper, Transpose or Conjugated transpose * SMALLN = .NOT.ZBIGP( ZIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZBIGP( ZIP82, M, N ) DO 150, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( TRANSA, 'N', ISEC, N, 0, ZERO, A, $ LDA, C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C or C := conjg( A' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A. * DO 120, J = 1, N CALL ZTRMV ( 'U', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to part of T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 130 CONTINUE * * C := T3'*C or C := conjg( T3' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A stored in T3. * DO 140, J = 1, N CALL ZTRMV ( 'U', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL ZGEMM ( TRANSA, 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 150 CONTINUE ELSE DELTA = ALPHA CLDC = ZCLD( LDC ) DO 240, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * upper triangular diagonal block of A is copied to * the upper triangular part of T2. * IF( NOCONJ )THEN DO 160, J = II+OFFD, II+ISEC-1 CALL ZCOPY ( J-II+1-OFFD, A( II, J ), 1, $ T2( 1, J-II+1 ), 1 ) 160 CONTINUE ELSE DO 180, J = II+OFFD, II+ISEC-1 DO 170, I = II, J-OFFD T2( I-II+1, J-II+1 ) = DCONJG( A( I, J ) ) 170 CONTINUE 180 CONTINUE END IF DO 230, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 190, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 190 CONTINUE ELSE DO 200, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 200 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 210, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 210 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 220, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 220 CONTINUE 230 CONTINUE * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II.GT.1 )THEN CALL ZGEMM ( TRANSA, 'N', ISEC, N, II-1, ALPHA, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 240 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*A*C. Left, Lower, No transpose. * SMALLN = .NOT.ZBIGP( ZIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZBIGP( ZIP82, M, N ) DO 280, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', 'N', ISEC, N, 0, ZERO, A, LDA, $ C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A*C, triangular matrix multiply involving * a lower triangular diagonal block of A. * DO 250, J = 1, N CALL ZTRMV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 250 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. * DO 260, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 260 CONTINUE * * C := T3*C, triangular matrix multiply involving * a lower triangular diagonal block of A stored * in T3. * DO 270, J = 1, N CALL ZTRMV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 270 CONTINUE END IF * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 280 CONTINUE ELSE DELTA = ALPHA CLDC = ZCLD( LDC ) DO 350, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 290, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 290 CONTINUE DO 340, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 300, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 300 CONTINUE ELSE DO 310, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the value of delta depends on * whether T2 stores a unit or non-unit triangular * block. Gamma and tsec are used to compensate for * a deficiency in ZGEMV that appears if the second * dimension (tsec) is zero. * DO 320, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 320 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 330, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 330 CONTINUE 340 CONTINUE * * C := alpha*A'*C + C, general matrix multiply * involving a rectangular block of A. * IF( II.GT.1 )THEN CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, ALPHA, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ONE, C( II, 1 ), LDC ) END IF 350 CONTINUE END IF ELSE * * Form C := alpha*A'*C or C := alpha*conjg( A' )*C. * Left, Lower, Transpose or Conjugated transpose * SMALLN = .NOT.ZBIGP( ZIP81, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZBIGP( ZIP82, M, N ) DO 390, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( TRANSA, 'N', ISEC, N, 0, ZERO, A, $ LDA, C, LDC, ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * C := A'*C or C := conjg( A' )*C, triangular * matrix multiply involving a lower triangular * diagonal block of A. * DO 360, J = 1, N CALL ZTRMV ( 'L', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 360 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to part of T3. * DO 370, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 370 CONTINUE * * C := T3'*C or C := conjg( T3' )*C, triangular * matrix multiply involving a upper triangular * diagonal block of A stored in T3. * DO 380, J = 1, N CALL ZTRMV ( 'L', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 380 CONTINUE END IF * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 390 CONTINUE ELSE DELTA = ALPHA CLDC = ZCLD( LDC ) DO 480, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * T2 := A or T2 := conjg( A ), a unit or non-unit * lower triangular diagonal block of A is copied to * the lower triangular part of T2. * IF( NOCONJ )THEN DO 400, J = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-II+1+OFFD, J-II+1 ), 1 ) 400 CONTINUE ELSE DO 420, J = II, II+ISEC-1-OFFD DO 410, I = J+OFFD, II+ISEC-1 T2( I-II+1, J-II+1 ) = DCONJG( A( I, J ) ) 410 CONTINUE 420 CONTINUE END IF DO 470, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 430, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 430 CONTINUE ELSE DO 440, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 440 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 450, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( I-II+1, I-II+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 450 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 460, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE * * C := alpha*A'*C + C or * C := alpha*conjg( A' )*C + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN CALL ZGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ ALPHA, A( II+ISEC, II ), LDA, $ C( II+ISEC, 1 ), LDC, ONE, $ C( II, 1 ), LDC ) END IF 480 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Form C := alpha*C*A. Right, Upper, No transpose. * TINYM = .NOT.ZBIGP( ZIP83, M, N ) IF( TINYM )THEN DO 500, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * upper triangular diagonal block of A. * DO 490, I = 1, M CALL ZTRMV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 500 CONTINUE ELSE DELTA = ALPHA DO 540, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) DO 530, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 510, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 510 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 520, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, C( II, J ), 1 ) 520 CONTINUE 530 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 540 CONTINUE END IF ELSE * * Form C := alpha*C*A' or C := alpha*C*conjg( A' ). * Right, Upper, Transpose or Conjugated transpose. * TINYM = .NOT.ZBIGP( ZIP83, M, N ) IF( TINYM )THEN DO 570, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', TRANSA, M, JSEC, 0, ZERO, C, $ LDC, A, LDA, ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T3. * DO 550, J = JJ+OFFD, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T3( J-JJ+1, 1 ), RCB ) 550 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a upper triangular * diagonal block of T3. * DO 560, I = 1, M CALL ZTRMV ( 'L', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 560 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 570 CONTINUE ELSE DELTA = ALPHA DO 640, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit upper triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 580, J = JJ+OFFD, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 580 CONTINUE ELSE DO 600, J = JJ+OFFD, JJ+JSEC-1 DO 590, I = JJ, J-OFFD T2( J-JJ+1, I-JJ+1 ) = DCONJG( A( I, J ) ) 590 CONTINUE 600 CONTINUE END IF DO 630, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 610, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 610 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 620, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 620 CONTINUE 630 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ, JJ+JSEC ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 640 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Form C := alpha*C*A. Right, Lower, No transpose. * TINYM = .NOT.ZBIGP( ZIP83, M, N ) IF( TINYM )THEN DO 660, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', 'N', M, JSEC, 0, ZERO, C, LDC, $ A, LDA, ALPHA, C( 1, JJ ), LDC ) * * C := C*A, triangular matrix multiply involving a * lower triangular diagonal block of A. * DO 650, I = 1, M CALL ZTRMV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 650 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 660 CONTINUE ELSE DELTA = ALPHA DO 700, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 DO 690, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 670, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 670 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the value of delta depends on * whether A is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 680, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ALPHA*A( J, J ) END IF GAMMA = ALPHA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, C( II, J ), 1 ) 680 CONTINUE 690 CONTINUE * * C := alpha*C*A + C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ ALPHA, C( 1, JJ+JSEC ), LDC, $ A( JJ+JSEC, JJ ), LDA, ONE, $ C( 1, JJ ), LDC ) END IF 700 CONTINUE END IF ELSE * * Form C := alpha*C*A'. Right, Lower, Transpose. * TINYM = .NOT.ZBIGP( ZIP83, M, N ) IF( TINYM )THEN DO 730, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := alpha*C, scale the rectangular block of C * with alpha. * IF( ALPHA.NE.ONE ) $ CALL ZGEMM ( 'N', TRANSA, M, JSEC, 0, ZERO, C, $ LDC, A, LDA, ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T3. * DO 710, J = JJ, JJ+JSEC-1-OFFD CALL ZCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T3( J-JJ+1, J-JJ+1+OFFD ), RCB ) 710 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a lower triangular * diagonal block of T3. * DO 720, I = 1, M CALL ZTRMV ( 'U', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 720 CONTINUE * * C := C*T3' or C := C*conjg( T3' ), triangular * matrix multiply involving a lower triangular * diagonal block of T3. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', TRANSA, M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 730 CONTINUE ELSE DELTA = ALPHA DO 800, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit lower triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 740, J = JJ, JJ+JSEC-1-OFFD CALL ZCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 740 CONTINUE ELSE DO 760, J = JJ, JJ+JSEC-1-OFFD DO 750, I = J+OFFD, JJ+JSEC-1 T2( J-JJ+1, I-JJ+1 ) = DCONJG( A( I, J ) ) 750 CONTINUE 760 CONTINUE END IF DO 790, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 770, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 770 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the value of delta depends on * whether T2 is a unit or non-unit triangular * matrix. Gamma and tsec are used to compensate * for a deficiency in ZGEMV that appears if the * second dimension (tsec) is zero. * DO 780, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ALPHA*T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = ALPHA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, C( II, J ), 1 ) 780 CONTINUE 790 CONTINUE * * C := alpha*C*A' + C or * C := alpha*C*conjg( A' ) + C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ.GT.1 )THEN CALL ZGEMM ( 'N', TRANSA, M, JSEC, JJ-1, ALPHA, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ONE, C( 1, JJ ), LDC ) END IF 800 CONTINUE END IF END IF END IF END IF * RETURN * * End of ZTRMM. * END SHAR_EOF fi # end of overwriting check if test -f 'ztrsm.f' then echo shar: will not over-write existing file "'ztrsm.f'" else cat << SHAR_EOF > 'ztrsm.f' SUBROUTINE ZTRSM ( SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, A, LDA, $ C, LDC ) * .. Scalar Arguments .. CHARACTER*1 SIDE, UPLO, TRANSA, DIAG INTEGER M, N, LDA, LDC COMPLEX*16 ALPHA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZTRSM solves one of the matrix equations * * op( A )*X = alpha*C, or X*op( A ) = alpha*C, * * where alpha is a scalar, X and C are m by n matrices, A is a unit, or * non-unit, upper or lower triangular matrix and op( A ) is one of * * op( A ) = A or op( A ) = A' or op( A ) = conjg( A' ). * * The matrix X is overwritten on C. * * Parameters * ========== * * SIDE - CHARACTER*1. * On entry, SIDE specifies whether op( A ) appears on the left * or right of X as follows: * * SIDE = 'L' or 'l' op( A )*X = alpha*C. * * SIDE = 'R' or 'r' X*op( A ) = alpha*C. * * Unchanged on exit. * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix A is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n' op( A ) = A. * * TRANSA = 'T' or 't' op( A ) = A'. * * TRANSA = 'C' or 'c' op( A ) = conjg( A' ). * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit triangular * as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of C. M must be at * least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of C. N must be * at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. When alpha is * zero then A is not referenced and C need not be set before * entry. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, k ), where k is m * when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'. * Before entry with UPLO = 'U' or 'u', the leading k by k * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading k by k * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When SIDE = 'L' or 'l' then * LDA must be at least max( 1, m ), when SIDE = 'R' or 'r' * then LDA must be at least max( 1, n ). * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the right-hand side matrix C, and on exit is * overwritten by the solution matrix X. * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * -- Rewritten in May-1994. * GEMM-Based Level 3 BLAS. * Per Ling, Institute of Information Processing, * University of Umea, Sweden. * * -- Modified in February-1996. * Per Ling, Department of Computing Science, * Umea University, Sweden. * * * .. Local Scalars .. INTEGER INFO, NROWA, OFFD LOGICAL LSIDE, UPPER, NOTR, NOCONJ, NOUNIT, $ CLDC, SMALLN, TINYN, TINYM INTEGER I, II, IX, ISEC, J, JJ, TIJ, JX, JSEC, TSEC COMPLEX*16 GAMMA, DELTA * .. Intrinsic Functions .. INTRINSIC MAX, MIN, MOD, DCONJG * .. External Functions .. LOGICAL LSAME, ZBIGP, ZCLD EXTERNAL LSAME, ZBIGP, ZCLD * .. External Subroutines .. EXTERNAL XERBLA EXTERNAL ZGEMM, ZGEMV, ZTRSV, ZCOPY * .. Parameters .. COMPLEX*16 ZERO, ONE INTEGER ZIP91, ZIP92, ZIP93 PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ), $ ONE = ( 1.0D+0, 0.0D+0 ), $ ZIP91 = 91, ZIP92 = 92, ZIP93 = 93 ) * .. User specified parameters for ZTRSM .. INTEGER RB, CB, RCB PARAMETER ( RCB = 44, RB = 44, CB = 44 ) COMPLEX*16 T1( RB, CB ), T2( CB, CB ), T3( RCB, RCB ) * .. * .. Executable Statements .. * * Test the input parameters. * LSIDE = LSAME( SIDE, 'L' ) UPPER = LSAME( UPLO, 'U' ) NOTR = LSAME( TRANSA, 'N' ) NOCONJ = LSAME( TRANSA, 'T' ) NOUNIT = LSAME( DIAG, 'N' ) IF( NOUNIT )THEN OFFD = 0 ELSE OFFD = 1 END IF IF( LSIDE )THEN NROWA = M ELSE NROWA = N END IF INFO = 0 IF( ( .NOT.LSIDE ).AND.( .NOT.LSAME( SIDE, 'R' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.UPPER ).AND.( .NOT.LSAME( UPLO, 'L' ) ) )THEN INFO = 2 ELSE IF( ( ( .NOT.NOTR ).AND.( .NOT.NOCONJ ) ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ) )THEN INFO = 3 ELSE IF( ( .NOT.NOUNIT ).AND.( .NOT.LSAME( DIAG, 'U' ) ) )THEN INFO = 4 ELSE IF( M.LT.0 )THEN INFO = 5 ELSE IF( N.LT.0 )THEN INFO = 6 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 9 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTRSM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN CALL ZGEMM ( 'N', 'N', M, N, 0, ZERO, C, MAX( LDA, LDC ), C, $ MAX( LDA, LDC ), ZERO, C, LDC ) RETURN END IF * * Start the operations. * IF( LSIDE )THEN IF( UPPER )THEN IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Upper, No transpose. * SMALLN = .NOT.ZBIGP( ZIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZBIGP( ZIP92, M, N ) DO 40, II = M-MOD( M-1, RCB ), 1, -RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a upper triangular diagonal block of A. The * block of X is overwritten on C. * DO 10, J = 1, N CALL ZTRSV ( 'U', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 10 CONTINUE ELSE * * T3 := A, a upper unit or non-unit triangular * diagonal block of A is copied to the upper * triangular part of T3. * DO 20, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 20 CONTINUE * * Solve T3*X = C, triangular system solve * involving a upper triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 30, J = 1, N CALL ZTRSV ( 'U', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 30 CONTINUE END IF 40 CONTINUE ELSE DELTA = ONE CLDC = ZCLD( LDC ) DO 110, II = M-MOD( M-1, CB ), 1, -CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II, II+ISEC-TIJ ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to the * lower triangular part of T2. * DO 50, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T2( I-II+1, 1 ), CB ) 50 CONTINUE DO 100, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 60, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 60 CONTINUE ELSE DO 70, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 70 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 80, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = II+ISEC-1-I TIJ = 1 IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 80 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 90, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 90 CONTINUE 100 CONTINUE 110 CONTINUE END IF ELSE * * Solve A'*X = alpha*C or conjg( A' )*X = alpha*C. * Left, Upper, Transpose or Conjugated transpose. * SMALLN = .NOT.ZBIGP( ZIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZBIGP( ZIP92, M, N ) DO 150, II = 1, M, RCB ISEC = MIN( RCB, M-II+1 ) * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL ZGEMM ( TRANSA, 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C or conjg( A' )*X = C, * triangular system solve involving a upper * triangular diagonal block of A. The block of X * is overwritten on C. * DO 120, J = 1, N CALL ZTRSV ( 'U', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 120 CONTINUE ELSE * * T3 := A, a unit or non-unit triangular diagonal * block of A is copied to T3. * DO 130, I = II+OFFD, II+ISEC-1 CALL ZCOPY ( I-II+1-OFFD, A( II, I ), 1, $ T3( 1, I-II+1 ), 1 ) 130 CONTINUE * * Solve T3'*X = C or conjg( T3' )*X = C, * triangular system solve involving a upper * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 140, J = 1, N CALL ZTRSV ( 'U', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 140 CONTINUE END IF 150 CONTINUE ELSE DELTA = ONE CLDC = ZCLD( LDC ) DO 240, II = 1, M, CB ISEC = MIN( CB, M-II+1 ) * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL ZGEMM ( TRANSA, 'N', ISEC, N, II-1, -ONE, $ A( 1, II ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * upper triangular diagonal block of A is copied to * the upper triangular part of T2. * IF( NOCONJ )THEN DO 160, J = II+OFFD, II+ISEC-1 CALL ZCOPY ( J-II+1-OFFD, A( II, J ), 1, $ T2( 1, J-II+1 ), 1 ) 160 CONTINUE ELSE DO 180, J = II+OFFD, II+ISEC-1 DO 170, I = II, J-OFFD T2( I-II+1, J-II+1 ) = DCONJG( A( I, J ) ) 170 CONTINUE 180 CONTINUE END IF DO 230, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 190, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 190 CONTINUE ELSE DO 200, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 200 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 210, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 210 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 220, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 220 CONTINUE 230 CONTINUE 240 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve A*X = alpha*C. Left, Lower, No transpose. * SMALLN = .NOT.ZBIGP( ZIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZBIGP( ZIP92, M, N ) DO 280, IX = MOD( M-1, RCB )+1, M, RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A*X = C, triangular system solve involving * a lower triangular diagonal block of A. The * block of X is overwritten on C. * DO 250, J = 1, N CALL ZTRSV ( 'L', 'N', DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 250 CONTINUE ELSE * * T3 := A, a lower unit or non-unit triangular * diagonal block of A is copied to the lower * triangular part of T3. The block of X is * overwritten on C. * DO 260, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 260 CONTINUE * * Solve T3*X = C, triangular system solve * involving a lower triangular diagonal block of A * stored in T3. The block of X is overwritten * on C. * DO 270, J = 1, N CALL ZTRSV ( 'L', 'N', DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 270 CONTINUE END IF 280 CONTINUE ELSE DELTA = ONE CLDC = ZCLD( LDC ) DO 350, IX = MOD( M-1, CB )+1, M, CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A*C + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL ZGEMM ( 'N', 'N', ISEC, N, II-1, -ONE, $ A( II, 1 ), LDA, C( 1, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to the * upper triangular part of T2. * DO 290, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T2( I-II+1, I-II+1+OFFD ), CB ) 290 CONTINUE DO 340, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 300, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 300 CONTINUE ELSE DO 310, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 310 CONTINUE END IF * * T1 := gamma*T1*T2 + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 stores a unit or non-unit * triangular block. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 320, I = II, II+ISEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TSEC = I-II IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 320 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 330, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 330 CONTINUE 340 CONTINUE 350 CONTINUE END IF ELSE * * Solve A'*X = alpha*C or conjg( A' )*X = alpha*C. * Left, Lower, Transpose or Conjugated transpose. * SMALLN = .NOT.ZBIGP( ZIP91, M, N ) IF( SMALLN )THEN TINYN = .NOT.ZBIGP( ZIP92, M, N ) DO 390, IX = M, 1, -RCB II = MAX( 1, IX-RCB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) IF( TINYN )THEN * * Solve A'*X = C or conjg( A' )*X = C, * triangular system solve involving a lower * triangular diagonal block of A. The block of X * is overwritten on C. * DO 360, J = 1, N CALL ZTRSV ( 'L', TRANSA, DIAG, ISEC, $ A( II, II ), LDA, C( II, J ), 1 ) 360 CONTINUE ELSE * * T3 := A, a unit or non-unit triangular diagonal * block of A is copied to T3. * DO 370, I = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-I-OFFD, A( I+OFFD, I ), $ 1, T3( I-II+1+OFFD, I-II+1 ), 1 ) 370 CONTINUE * * Solve T3'*X = C or conjg( T3' )*X = C, * triangular system solve involving a lower * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 380, J = 1, N CALL ZTRSV ( 'L', TRANSA, DIAG, ISEC, $ T3( 1, 1 ), RCB, C( II, J ), 1 ) 380 CONTINUE END IF 390 CONTINUE ELSE DELTA = ONE CLDC = ZCLD( LDC ) DO 480, IX = M, 1, -CB II = MAX( 1, IX-CB+1 ) ISEC = IX-II+1 * * C := -1*A'*C + alpha*C or * C := -1*conjg( A' )*C + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( II+ISEC.LE.M )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( TRANSA, 'N', ISEC, N, M-II-ISEC+1, $ GAMMA, A( II+ISEC-TIJ, II ), LDA, $ C( II+ISEC-TIJ, 1 ), LDC, $ ALPHA, C( II, 1 ), LDC ) * * T2 := A or T2 := conjg( A ), a unit or non-unit * lower triangular diagonal block of A is copied to * the lower triangular part of T2. * IF( NOCONJ )THEN DO 400, J = II, II+ISEC-1-OFFD CALL ZCOPY ( II+ISEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-II+1+OFFD, J-II+1 ), 1 ) 400 CONTINUE ELSE DO 420, J = II, II+ISEC-1-OFFD DO 410, I = J+OFFD, II+ISEC-1 T2( I-II+1, J-II+1 ) = DCONJG( A( I, J ) ) 410 CONTINUE 420 CONTINUE END IF DO 470, JJ = 1, N, RB JSEC = MIN( RB, N-JJ+1 ) * * T1 := C', the transpose of a rectangular block * of C is copied to T1. * IF( CLDC )THEN DO 430, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( J-JJ+1, 1 ), RB ) 430 CONTINUE ELSE DO 440, I = II, II+ISEC-1 CALL ZCOPY ( JSEC, C( I, JJ ), LDC, $ T1( 1, I-II+1 ), 1 ) 440 CONTINUE END IF * * T1 := gamma*T1*A + delta*T1, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 450, I = II+ISEC-1, II, -1 IF( NOUNIT )THEN DELTA = ONE/T2( I-II+1, I-II+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = II+ISEC-1-I IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', JSEC, TSEC, GAMMA, $ T1( 1, I-II+1+TIJ ), RB, $ T2( I-II+1+TIJ, I-II+1 ), 1, $ DELTA, T1( 1, I-II+1 ), 1 ) 450 CONTINUE * * C := T1', the transpose of T1 is copied back * to C. * DO 460, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( J-JJ+1, 1 ), RB, $ C( II, J ), 1 ) 460 CONTINUE 470 CONTINUE 480 CONTINUE END IF END IF END IF ELSE IF( UPPER )THEN IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Upper, No transpose. * TINYM = .NOT.ZBIGP( ZIP93, M, N ) IF( TINYM )THEN DO 500, JJ = 1, N, RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a upper triangular diagonal block of A. The block * of X is overwritten on C. * DO 490, I = 1, M CALL ZTRSV ( 'U', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 490 CONTINUE 500 CONTINUE ELSE DELTA = ONE DO 550, JJ = 1, N, CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * CALL ZGEMM ( 'N', 'N', M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( 1, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 540, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 510, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 510 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 520, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, A( JJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 520 CONTINUE * * C := T1, T1 is copied back to C. * DO 530, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 530 CONTINUE 540 CONTINUE 550 CONTINUE END IF ELSE * * Solve X*A' = alpha*C or X*conjg( A' ) = alpha*C. * Right, Upper, Transpose or Conjugated transpose. * TINYM = .NOT.ZBIGP( ZIP93, M, N ) IF( TINYM )THEN DO 580, JJ = N-MOD( N-1, RCB ), 1, -RCB JSEC = MIN( RCB, N-JJ+1 ) * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a upper unit or non-unit * triangular diagonal block of A is copied to T3. * DO 560, J = JJ+OFFD, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T3( J-JJ+1, 1 ), RCB ) 560 CONTINUE * * Solve X*T3' = C or X*conjg( T3' ) = C, triangular * system solve involving the transpose of a upper * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 570, I = 1, M CALL ZTRSV ( 'L', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 570 CONTINUE 580 CONTINUE ELSE DELTA = ONE DO 660, JJ = N-MOD( N-1, CB ), 1, -CB JSEC = MIN( CB, N-JJ+1 ) * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', TRANSA, M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ, JJ+JSEC-TIJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit upper triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 590, J = JJ+OFFD, JJ+JSEC-1 CALL ZCOPY ( J-JJ+1-OFFD, A( JJ, J ), 1, $ T2( J-JJ+1, 1 ), CB ) 590 CONTINUE ELSE DO 610, J = JJ+OFFD, JJ+JSEC-1 DO 600, I = JJ, J-OFFD T2( J-JJ+1, I-JJ+1 ) = DCONJG( A( I, J ) ) 600 CONTINUE 610 CONTINUE END IF DO 650, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 620, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 620 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 630, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, $ T2( J-JJ+1+TIJ, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 630 CONTINUE * * C := T1, T1 is copied back to C. * DO 640, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 640 CONTINUE 650 CONTINUE 660 CONTINUE END IF END IF ELSE IF( NOTR )THEN * * Solve X*A = alpha*C. Right, Lower, No transpose. * TINYM = .NOT.ZBIGP( ZIP93, M, N ) IF( TINYM )THEN DO 680, JX = N, 1, -RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * Solve X*A = C, triangular system solve involving * a lower triangular diagonal block of A. The block * of X is overwritten on C. * DO 670, I = 1, M CALL ZTRSV ( 'L', 'T', DIAG, JSEC, $ A( JJ, JJ ), LDA, C( I, JJ ), LDC ) 670 CONTINUE 680 CONTINUE ELSE DELTA = ONE DO 730, JX = N, 1, -CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A + alpha*C, general matrix multiply * involving a rectangular block of A. * IF( JJ+JSEC.LE.N )THEN TIJ = 0 GAMMA = -ONE ELSE TIJ = 1 GAMMA = ZERO END IF CALL ZGEMM ( 'N', 'N', M, JSEC, N-JJ-JSEC+1, $ GAMMA, C( 1, JJ+JSEC-TIJ ), LDC, $ A( JJ+JSEC-TIJ, JJ ), LDA, $ ALPHA, C( 1, JJ ), LDC ) DO 720, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 690, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 690 CONTINUE * * C := gamma*T1*A + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether A is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 700, J = JJ+JSEC-1, JJ, -1 IF( NOUNIT )THEN DELTA = ONE/A( J, J ) END IF GAMMA = -DELTA TIJ = 1 TSEC = JJ+JSEC-1-J IF( TSEC.EQ.0 )THEN GAMMA = ZERO TIJ = 0 TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, J-JJ+1+TIJ ), RB, A( J+TIJ, J ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 700 CONTINUE * * C := T1, T1 is copied back to C. * DO 710, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 710 CONTINUE 720 CONTINUE 730 CONTINUE END IF ELSE * * Solve X*A' = alpha*C or X*conjg( A' ) = alpha*C. * Right, Lower, Transpose or Conjugated transpose. * TINYM = .NOT.ZBIGP( ZIP93, M, N ) IF( TINYM )THEN DO 760, JX = MOD( N-1, RCB )+1, N, RCB JJ = MAX( 1, JX-RCB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL ZGEMM ( 'N', TRANSA, M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T3 := A', the transpose of a lower unit or non-unit * triangular diagonal block of A is copied to T3. * DO 740, J = JJ, JJ+JSEC-1-OFFD CALL ZCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T3( J-JJ+1, J-JJ+1+OFFD ), RCB ) 740 CONTINUE * * Solve X*T3' = C or X*conjg( T3' ) = C, triangular * system solve involving the transpose of a lower * triangular diagonal block of A stored in T3. The * block of X is overwritten on C. * DO 750, I = 1, M CALL ZTRSV ( 'U', TRANSA, DIAG, JSEC, $ T3( 1, 1 ), RCB, C( I, JJ ), LDC ) 750 CONTINUE 760 CONTINUE ELSE DELTA = ONE DO 840, JX = MOD( N-1, CB )+1, N, CB JJ = MAX( 1, JX-CB+1 ) JSEC = JX-JJ+1 * * C := -1*C*A' + alpha*C or * C := -1*C*conjg( A' ) + alpha*C, matrix multiply * involving the transpose of a rectangular block * of A. * CALL ZGEMM ( 'N', TRANSA, M, JSEC, JJ-1, -ONE, $ C( 1, 1 ), LDC, A( JJ, 1 ), LDA, $ ALPHA, C( 1, JJ ), LDC ) * * T2 := A' or T2 := conjg( A' ), the transpose of a * unit or non-unit lower triangular diagonal block of * A is copied to the lower triangular part of T2. * IF( NOCONJ )THEN DO 770, J = JJ, JJ+JSEC-1-OFFD CALL ZCOPY ( JJ+JSEC-J-OFFD, A( J+OFFD, J ), $ 1, T2( J-JJ+1, J-JJ+1+OFFD ), CB ) 770 CONTINUE ELSE DO 790, J = JJ, JJ+JSEC-1-OFFD DO 780, I = J+OFFD, JJ+JSEC-1 T2( J-JJ+1, I-JJ+1 ) = DCONJG( A( I, J ) ) 780 CONTINUE 790 CONTINUE END IF DO 830, II = 1, M, RB ISEC = MIN( RB, M-II+1 ) * * T1 := C, a rectangular block of C is copied * to T1. * DO 800, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, C( II, J ), 1, $ T1( 1, J-JJ+1 ), 1 ) 800 CONTINUE * * C := gamma*T1*T2 + delta*C, triangular matrix * multiply where the values of gamma and delta * depend on whether T2 is a unit or non-unit * triangular matrix. Gamma and tsec are also used * to compensate for a deficiency in ZGEMV that * appears if the second dimension (tsec) is zero. * DO 810, J = JJ, JJ+JSEC-1 IF( NOUNIT )THEN DELTA = ONE/T2( J-JJ+1, J-JJ+1 ) END IF GAMMA = -DELTA TSEC = J-JJ IF( TSEC.EQ.0 )THEN GAMMA = ZERO TSEC = 1 END IF CALL ZGEMV ( 'N', ISEC, TSEC, GAMMA, $ T1( 1, 1 ), RB, T2( 1, J-JJ+1 ), 1, $ DELTA, T1( 1, J-JJ+1 ), 1 ) 810 CONTINUE * * C := T1, T1 is copied back to C. * DO 820, J = JJ, JJ+JSEC-1 CALL ZCOPY ( ISEC, T1( 1, J-JJ+1 ), 1, $ C( II, J ), 1 ) 820 CONTINUE 830 CONTINUE 840 CONTINUE END IF END IF END IF END IF * RETURN * * End of ZTRSM. * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'make.gbinc' then echo shar: will not over-write existing file "'make.gbinc'" else cat << SHAR_EOF > 'make.gbinc' include ../../make.inc ### GEMM-Based Level 3 BLAS library and benchmark ######################## # # The following libraries are specified, the GEMM-based level 3 BLAS # library produced (GBL3B), the library with the underlying BLAS # routines used (ULIB), and the library with the timing functions SECOND # and DSECND (UTMG). # # CRETMG specifies if a timing library are to be created using the # implementations of SECOND and DSECND stored in the subdirectory # TMGLIB. # ULIB = $(USELIB) UULIB = $(USEULIB) UTMG = $(USETMG) GBL3B = $(CREGBLIB) CTMG = $(CRETMG) # ### Compiler options ##################################################### # # The compiler options are specified as follows for the different # programs and libraries: # # GBOPT : the GEMM-based level 3 BLAS routines # GBBOPT : the GEMM-based performance benchmark programs # AXOPT : various auxiliary routines # GBOPT = $(GBL3BOPT) GBBOPT = $(GBBENOPT) AXOPT = $(AUXOPT) SHAR_EOF fi # end of overwriting check cd .. if test ! -d 'INSTALL' then mkdir 'INSTALL' fi cd 'INSTALL' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.inc all: testlsame $(CRETMG) testlsame: lsame.o lsametst.o $(LOADER) $(LOADOPT) -o testlsame lsame.o lsametst.o testlsame $(CRETMG): second.o secondtst.o dsecnd.o dsecndtst.o $(LOADER) $(LOADOPT) -o testsecond second.o secondtst.o $(LOADER) $(LOADOPT) -o testdsecnd dsecnd.o dsecndtst.o testsecond; testdsecnd .f.o: ; $(FORTRAN) $(TSTOPT) -c $< clean: rm -f *.o testlsame testsecond testdsecnd SHAR_EOF fi # end of overwriting check if test -f 'dsecnd.f' then echo shar: will not over-write existing file "'dsecnd.f'" else cat << SHAR_EOF > 'dsecnd.f' DOUBLE PRECISION FUNCTION DSECND( ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * Purpose * ======= * * DSECND returns the user time for a process in seconds. * This version gets the time from the system function ETIME. * * ===================================================================== * * .. Local Scalars .. REAL T1 * .. * .. Local Arrays .. REAL TARRAY( 2 ) * .. * .. External Functions .. REAL ETIME EXTERNAL ETIME * .. * .. Executable Statements .. * T1 = ETIME( TARRAY ) DSECND = TARRAY( 1 ) RETURN * * End of DSECND * END SHAR_EOF fi # end of overwriting check if test -f 'dsecndtst.f' then echo shar: will not over-write existing file "'dsecndtst.f'" else cat << SHAR_EOF > 'dsecndtst.f' PROGRAM TEST5 * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Parameters .. INTEGER NMAX, ITS PARAMETER ( NMAX = 100, ITS = 5000 ) * .. * .. Local Scalars .. INTEGER I, J DOUBLE PRECISION ALPHA, AVG, T1, T2, TNOSEC * .. * .. Local Arrays .. DOUBLE PRECISION X( NMAX ), Y( NMAX ) * .. * .. External Functions .. DOUBLE PRECISION DSECND EXTERNAL DSECND * .. * .. Intrinsic Functions .. INTRINSIC DBLE * .. * .. Executable Statements .. * * * Initialize X and Y * DO 10 I = 1, NMAX X( I ) = DBLE( 1 ) / DBLE( I ) Y( I ) = DBLE( NMAX-I ) / DBLE( NMAX ) 10 CONTINUE ALPHA = 0.315D0 * * Time 1,000,000 DAXPY operations * T1 = DSECND( ) DO 30 J = 1, ITS DO 20 I = 1, NMAX Y( I ) = Y( I ) + ALPHA*X( I ) 20 CONTINUE ALPHA = -ALPHA 30 CONTINUE T2 = DSECND( ) WRITE( 6, 9999 )T2 - T1 IF( T2-T1.GT.0.0D0 ) THEN WRITE( 6, 9998 )1.0D0 / ( T2-T1 ) ELSE WRITE( 6, 9994 ) END IF TNOSEC = T2 - T1 * * Time 1,000,000 DAXPY operations with DSECND in the outer loop * T1 = DSECND( ) DO 50 J = 1, ITS DO 40 I = 1, NMAX Y( I ) = Y( I ) + ALPHA*X( I ) 40 CONTINUE ALPHA = -ALPHA T2 = DSECND( ) 50 CONTINUE * * Compute the time in milliseconds used by an average call * to DSECND. * WRITE( 6, 9997 )T2 - T1 AVG = ( ( T2-T1 )-TNOSEC )*1000.D0 / DBLE( ITS ) WRITE( 6, 9996 )AVG * * Compute the equivalent number of floating point operations used * by an average call to DSECND. * IF( TNOSEC.GT.0.0D0 ) $ WRITE( 6, 9995 )1000.D0*AVG / TNOSEC * 9999 FORMAT( ' Time for 1,000,000 DAXPY ops = ', G10.3, ' seconds' ) 9998 FORMAT( ' DAXPY performance rate = ', G10.3, ' mflops ' ) 9997 FORMAT( ' Including DSECND, time = ', G10.3, ' seconds' ) 9996 FORMAT( ' Average time for DSECND = ', G10.3, $ ' milliseconds' ) 9995 FORMAT( ' Equivalent floating point ops = ', G10.3, ' ops' ) 9994 FORMAT( ' *** Error: Time for operations was zero' ) CALL MYSUB(NMAX,X,Y) END SUBROUTINE MYSUB(N,X,Y) INTEGER N DOUBLE PRECISION X(N), Y(N) RETURN END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'lsametst.f' then echo shar: will not over-write existing file "'lsametst.f'" else cat << SHAR_EOF > 'lsametst.f' PROGRAM TEST1 * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Local Scalars .. INTEGER I1, I2 * .. * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Executable Statements .. * * * Determine the character set. * I1 = ICHAR( 'A' ) I2 = ICHAR( 'a' ) IF( I2-I1.EQ.32 ) THEN WRITE( *, * ) ' ASCII character set' ELSE WRITE( *, * ) ' Non-ASCII character set, IOFF should be ',I2-I1 END IF * * Test LSAME. * IF( .NOT.LSAME( 'A', 'A' ) ) $ WRITE( *, 9999 )'A', 'A' IF( .NOT.LSAME( 'A', 'a' ) ) $ WRITE( *, 9999 )'A', 'a' IF( .NOT.LSAME( 'a', 'A' ) ) $ WRITE( *, 9999 )'a', 'A' IF( .NOT.LSAME( 'a', 'a' ) ) $ WRITE( *, 9999 )'a', 'a' IF( LSAME( 'A', 'B' ) ) $ WRITE( *, 9998 )'A', 'B' IF( LSAME( 'A', 'b' ) ) $ WRITE( *, 9998 )'A', 'b' IF( LSAME( 'a', 'B' ) ) $ WRITE( *, 9998 )'a', 'B' IF( LSAME( 'a', 'b' ) ) $ WRITE( *, 9998 )'a', 'b' IF( LSAME( 'O', '/' ) ) $ WRITE( *, 9998 )'O', '/' IF( LSAME( '/', 'O' ) ) $ WRITE( *, 9998 )'/', 'O' IF( LSAME( 'o', '/' ) ) $ WRITE( *, 9998 )'o', '/' IF( LSAME( '/', 'o' ) ) $ WRITE( *, 9998 )'/', 'o' WRITE( *, * )' Tests completed' * 9999 FORMAT( ' *** Error: LSAME( ', A1, ', ', A1, ') is .FALSE.' ) 9998 FORMAT( ' *** Error: LSAME( ', A1, ', ', A1, ') is .TRUE.' ) END SHAR_EOF fi # end of overwriting check if test -f 'second.f' then echo shar: will not over-write existing file "'second.f'" else cat << SHAR_EOF > 'second.f' REAL FUNCTION SECOND( ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * Purpose * ======= * * SECOND returns the user time for a process in seconds. * This version gets the time from the system function ETIME. * * ===================================================================== * * .. Local Scalars .. REAL T1 * .. * .. Local Arrays .. REAL TARRAY( 2 ) * .. * .. External Functions .. REAL ETIME EXTERNAL ETIME * .. * .. Executable Statements .. * T1 = ETIME( TARRAY ) SECOND = TARRAY( 1 ) RETURN * * End of SECOND * END SHAR_EOF fi # end of overwriting check if test -f 'secondtst.f' then echo shar: will not over-write existing file "'secondtst.f'" else cat << SHAR_EOF > 'secondtst.f' PROGRAM TEST4 * * -- LAPACK test routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Parameters .. INTEGER NMAX, ITS PARAMETER ( NMAX = 100, ITS = 5000 ) * .. * .. Local Scalars .. INTEGER I, J REAL ALPHA, AVG, T1, T2, TNOSEC * .. * .. Local Arrays .. REAL X( NMAX ), Y( NMAX ) * .. * .. External Functions .. REAL SECOND EXTERNAL SECOND * .. * .. Intrinsic Functions .. INTRINSIC REAL * .. * .. Executable Statements .. * * * Initialize X and Y * DO 10 I = 1, NMAX X( I ) = REAL( 1 ) / REAL( I ) Y( I ) = REAL( NMAX-I ) / REAL( NMAX ) 10 CONTINUE ALPHA = 0.315 * * Time 1,000,000 SAXPY operations * T1 = SECOND( ) DO 30 J = 1, ITS DO 20 I = 1, NMAX Y( I ) = Y( I ) + ALPHA*X( I ) 20 CONTINUE ALPHA = -ALPHA 30 CONTINUE T2 = SECOND( ) WRITE( 6, 9999 )T2 - T1 IF( T2-T1.GT.0.0 ) THEN WRITE( 6, 9998 )1.0 / ( T2-T1 ) ELSE WRITE( 6, 9994 ) END IF TNOSEC = T2 - T1 * * Time 1,000,000 SAXPY operations with SECOND in the outer loop * T1 = SECOND( ) DO 50 J = 1, ITS DO 40 I = 1, NMAX Y( I ) = Y( I ) + ALPHA*X( I ) 40 CONTINUE ALPHA = -ALPHA T2 = SECOND( ) 50 CONTINUE * * Compute the time used in milliseconds used by an average call * to SECOND. * WRITE( 6, 9997 )T2 - T1 AVG = ( ( T2-T1 ) - TNOSEC ) * 1000./REAL( ITS ) WRITE( 6, 9996 )AVG * * Compute the equivalent number of floating point operations used * by an average call to SECOND. * IF( TNOSEC.GT.0.0 ) $ WRITE( 6, 9995 )1000.*AVG / TNOSEC * 9999 FORMAT( ' Time for 1,000,000 SAXPY ops = ', G10.3, ' seconds' ) 9998 FORMAT( ' SAXPY performance rate = ', G10.3, ' mflops ' ) 9997 FORMAT( ' Including SECOND, time = ', G10.3, ' seconds' ) 9996 FORMAT( ' Average time for SECOND = ', G10.3, $ ' milliseconds' ) 9995 FORMAT( ' Equivalent floating point ops = ', G10.3, ' ops' ) 9994 FORMAT( ' *** Error: Time for operations was zero' ) CALL MYSUB(NMAX,X,Y) END SUBROUTINE MYSUB(N,X,Y) INTEGER N REAL X(N), Y(N) RETURN END SHAR_EOF fi # end of overwriting check cd .. if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' # # Top level Makefile for the GEMM-based level 3 BLAS. # March, 1997. # include make.inc all: install $(CRETMG) gblib $(CREULIB) testing timing clean: cleaninstall cleangblib cleanunderlib cleantesting cleantiming install: ( cd INSTALL; $(MAKE); \ cp lsame.f ../GBL3B/SGBL3B; cp lsame.f ../GBL3B/DGBL3B; \ cp lsame.f ../GBL3B/CGBL3B; cp lsame.f ../GBL3B/ZGBL3B; \ cp lsame.f ../GBBEN/SBENCH; cp lsame.f ../GBBEN/DBENCH; \ cp lsame.f ../GBBEN/CBENCH; cp lsame.f ../GBBEN/ZBENCH; \ cp lsame.f ../UNDERLIB; ) $(CRETMG): ( cd INSTALL; \ cp second.f ../GBBEN/TMGLIB; cp dsecnd.f ../GBBEN/TMGLIB ) gblib: ( cd GBL3B; $(MAKE) ) $(CREULIB): ( cd UNDERLIB; $(MAKE) ) testing: ( cd TESTING; $(MAKE) ) timing: ( cd GBBEN; $(MAKE) ) cleaninstall: ( cd INSTALL; $(MAKE) clean ) cleangblib: ( cd GBL3B; $(MAKE) clean ) cleanunderlib: ( cd UNDERLIB; $(MAKE) clean ) cleantesting: ( cd TESTING; $(MAKE) clean ) cleantiming: ( cd GBBEN; $(MAKE) clean ) SHAR_EOF fi # end of overwriting check if test -f 'README' then echo shar: will not over-write existing file "'README'" else cat << SHAR_EOF > 'README' GEMM-based Level 3 BLAS: High-performance model implementations and performance evaluation benchmark. March, 1997. ----------------------------------------------------------------------- The software comes in four different Fortran data types (real, double, complex, and double complex) and is designed to be easy to install and use on different platforms. Software directories: --------------------- The top level directory includes this README file and the following five subdirectories for the source code: GBBEN: Contains four subdirectories SBENCH, DBENCH, CBENCH, and ZBENCH, one subdirectory for each data type of the GEMM-based level 3 BLAS performance evaluation benchmark, and furthermore, the subdirectory TMGLIB with timing routines. The GEMM-based level 3 BLAS performance evaluation benchmark, is a tool for evaluating and comparing the performance of different implementations of the level 3 BLAS with the GEMM-based model implementations. See paper [TOMS-I]. GBL3B: Contains four subdirectories SGBL3B, DGBL3B, CGBL3B, and ZGBL3B, one subdirectory corresponding to each data type of the GEMM-based level 3 BLAS model implementations. The model implementations are structured to effectively reduce data traffic in a memory hierarchy. See paper [TOMS-I]. INSTALL: Contains the machine-dependent functions SECOND, DSECND, and LSAME, and a test program for each function. These functions should be modified for the target system. The resolution of the timing functions should preferably be microseconds or smaller. TESTING: Contains test programs for the level 3 BLAS (source code in subdirectory SRC). These programs test the correctness of Level 3 BLAS implementations. The programs are from the LAPACK package. UNDERLIB: Contains underlying BLAS routines called by the GEMM- based level 3 BLAS. These underlying routines are "original" BLAS implementations from the LAPACK package and they are only included for completness. In order to obtain high performance they should be replaced by implementations optimized for the target machine. Makefiles: ---------- Each directory in the hierarchy includes a Makefile. The command 'make' in any of the directories produces all programs and libraries contained in the current directory and subsequent subdirectories. Similarly, the command 'make clean' remove alls object files and executables. Specification of compiler flags, libraries etc: ----------------------------------------------- The file 'make.inc' in the top directory specifies the Fortran compiler, loader, archiver, flags, and libraries, and may require changes for different target systems. Notice that compiler flags for the GEMM-based level 3 BLAS benchmark and model implementations are specified in the Makefiles of the subdirectories GBBEN/*BENCH and GBL3B/*GBL3B. Correctness testing: -------------------- Executable programs for testing the correctness of the GEMM-based level 3 BLAS are stored in the subdirectory TESTING. We recommend that you run the test programs. We illustrate how the test programs can be executed in a Unix environment. The test programs stored in the directory TESTING are executed as follows (example in double precision): % xblat3d < dblat3.in The tests are specified in the example input file 'dblat3.in' and can be modified as desired. The result of an execution is presented in the output file 'DBLAT3.SUMM'. Machine-dependent parameters: ----------------------------- Each of the GEMM-based model implementations has a few system (machine) dependent parameters that are given values at compile time. These specify internal block sizes, cache characteristics, and branch points for alternative code sections, which are given as input to a program '*sgpm.f' that facilitates the tuning of these parameters. For simplicity, we also provide sample values for some common architectures ('*gpm.in'). The following command given in the subdirectory GBBEN/DGBL3B (double precision): % dsgpm < dgpm.in will change the system dependent parameters in the source code of each GEMM-based routine according to the specifications in 'dgpm.in'. The parameters can be specified as desired in 'dgpm.in'. The benchmark programs have built-in GEMM-based level 3 BLAS routines that are renamed and used for performance comparison with other specified level 3 BLAS implementations. The system dependent parameters for these built-in GEMM-based routines can similarly be changed with the program '*sbpm.f'. We refer to the paper [TOMS-II] for detailed information on how to specify these parameters. Performance timing: ------------------- Executable programs for timing the performance of the GEMM-based level 3 BLAS are stored in the subdirectory GBBEN/*BENCH. We illustrate how the timing programs can be executed in a Unix environment. The benchmark programs stored in the directories GBBEN/*BENCH are executed as follows (example in double precision): % dgbtim < example.in > example.out The routines and problems to be timed are specified in the input file 'example.in' and the output result is written to the file 'example.out'. The tests in the input file can be modified as desired. We propose two standard test which are enclosed in the files 'dmark01.in' and 'dmark02.in'. The problems in the two tests are similar. However, some of the matrix dimensions are larger in 'dmark02.in' than in 'dmark01.in'. See also paper [TOMS-II]. Further information and questions: ---------------------------------- For further information see: [TOMS-I] GEMM-based Level 3 BLAS: High-performance model implementations and performance evaluation benchmark (Bo Kagstrom, Per Ling and Charles Van Loan). [TOMS-II] GEMM-based Level 3 BLAS: Portability and optimization issues (Bo Kagstrom, Per Ling and Charles Van Loan). For questions regarding the installation and use of the software please contact Per Ling (Per.Ling@cs.umu.se). SHAR_EOF fi # end of overwriting check if test ! -d 'TESTING' then mkdir 'TESTING' fi cd 'TESTING' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.inc all: tst tst: ( cd SRC; $(MAKE) ) clean: rm -f xblat3s xblat3d xblat3c xblat3z ( cd SRC; $(MAKE) clean ) SHAR_EOF fi # end of overwriting check if test ! -d 'SRC' then mkdir 'SRC' fi cd 'SRC' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../../make.inc ####################################################################### # This makefile creates the test programs for the BLAS 3 routines. # The test files are grouped as follows: # SBLAT3 -- Single precision real test routines # CBLAT3 -- Single precision complex test routines # DBLAT3 -- Double precision real test routines # ZBLAT3 -- Double precision complex test routines # # Test programs can be generated for all or some of the four different # precisions. To create the test programs, enter make followed by one # or more of the precisions desired. Some examples: # make single # make single complex # make single double complex complex16 # Alternatively, the command # make # without any arguments creates all four test programs. # The executable files which are created are called # xblat3s, xblat3d, xblat3c, and xblat3z # # To remove the object files after the executable files have been # created, enter # make clean # To force the source files to be recompiled, enter, for example, # make single FRC=FRC # ####################################################################### TSTBLAS = $(USELIB) $(USEULIB) SBLAT3 = sblat3.o CBLAT3 = cblat3.o DBLAT3 = dblat3.o ZBLAT3 = zblat3.o all: single double complex complex16 single: xblat3s double: xblat3d complex: xblat3c complex16: xblat3z xblat3s: $(SBLAT3) $(LOADER) $(LOADOPT) $(SBLAT3) \ $(TSTBLAS) -o ../xblat3s xblat3c: $(CBLAT3) $(LOADER) $(LOADOPT) $(CBLAT3) \ $(TSTBLAS) -o ../xblat3c xblat3d: $(DBLAT3) $(LOADER) $(LOADOPT) $(DBLAT3) \ $(TSTBLAS) -o ../xblat3d xblat3z: $(ZBLAT3) $(LOADER) $(LOADOPT) $(ZBLAT3) \ $(TSTBLAS) -o ../xblat3z $(SBLAT3): $(FRC) $(CBLAT3): $(FRC) $(DBLAT3): $(FRC) $(ZBLAT3): $(FRC) FRC: @FRC=$(FRC) clean: rm -f *.o .f.o: $(FORTRAN) $(TSTOPT) -c $*.f SHAR_EOF fi # end of overwriting check if test -f 'cblat3.f' then echo shar: will not over-write existing file "'cblat3.f'" else cat << SHAR_EOF > 'cblat3.f' PROGRAM CBLAT3 * * Test program for the COMPLEX Level 3 Blas. * * The program must be driven by a short data file. The first 14 records * of the file are read using list-directed input, the last 9 records * are read using the format ( A6, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the * following 23 lines: * 'CBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE * 6 UNIT NUMBER OF SUMMARY FILE * 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. * F LOGICAL FLAG, T TO STOP ON FAILURES. * T LOGICAL FLAG, T TO TEST ERROR EXITS. * 16.0 THRESHOLD VALUE OF TEST RATIO * 6 NUMBER OF VALUES OF N * 0 1 2 3 5 9 VALUES OF N * 3 NUMBER OF VALUES OF ALPHA * (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA * 3 NUMBER OF VALUES OF BETA * (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA * CGEMM T PUT F FOR NO TEST. SAME COLUMNS. * CHEMM T PUT F FOR NO TEST. SAME COLUMNS. * CSYMM T PUT F FOR NO TEST. SAME COLUMNS. * CTRMM T PUT F FOR NO TEST. SAME COLUMNS. * CTRSM T PUT F FOR NO TEST. SAME COLUMNS. * CHERK T PUT F FOR NO TEST. SAME COLUMNS. * CSYRK T PUT F FOR NO TEST. SAME COLUMNS. * CHER2K T PUT F FOR NO TEST. SAME COLUMNS. * CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. * * See: * * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. * A Set of Level 3 Basic Linear Algebra Subprograms. * * Technical Memorandum No.88 (Revision 1), Mathematics and * Computer Science Division, Argonne National Laboratory, 9700 * South Cass Avenue, Argonne, Illinois 60439, US. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS PARAMETER ( NSUBS = 9 ) COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RZERO, RHALF, RONE PARAMETER ( RZERO = 0.0, RHALF = 0.5, RONE = 1.0 ) INTEGER NMAX PARAMETER ( NMAX = 248 ) INTEGER NIDMAX, NALMAX, NBEMAX * PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) PARAMETER ( NIDMAX = 20, NALMAX = 7, NBEMAX = 7 ) * .. Local Scalars .. REAL EPS, ERR, THRESH INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB CHARACTER*6 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. COMPLEX AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), $ ALF( NALMAX ), AS( NMAX*NMAX ), $ BB( NMAX*NMAX ), BET( NBEMAX ), $ BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ W( 2*NMAX ) REAL G( NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) CHARACTER*6 SNAMES( NSUBS ) * .. External Functions .. REAL SDIFF LOGICAL LCE EXTERNAL SDIFF, LCE * .. External Subroutines .. EXTERNAL CCHK1, CCHK2, CCHK3, CCHK4, CCHK5, CCHKE, CMMCH * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'CGEMM ', 'CHEMM ', 'CSYMM ', 'CTRMM ', $ 'CTRSM ', 'CHERK ', 'CSYRK ', 'CHER2K', $ 'CSYR2K'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT * OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. * READ( NIN, FMT = * )SNAPS READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI REWI = REWI.AND.TRACE * Read the flag that directs stopping on any failure. READ( NIN, FMT = * )SFATAL * Read the flag that indicates whether error exits are to be tested. READ( NIN, FMT = * )TSTERR * Read the threshold value of the test ratio READ( NIN, FMT = * )THRESH * * Read and check the parameter values for the tests. * * Values of N READ( NIN, FMT = * )NIDIM IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN WRITE( NOUT, FMT = 9997 )'N', NIDMAX GO TO 220 END IF READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) DO 10 I = 1, NIDIM IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN WRITE( NOUT, FMT = 9996 )NMAX GO TO 220 END IF 10 CONTINUE * Values of ALPHA READ( NIN, FMT = * )NALF IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX GO TO 220 END IF READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) * Values of BETA READ( NIN, FMT = * )NBET IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX GO TO 220 END IF READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) * * Report values of parameters. * WRITE( NOUT, FMT = 9995 ) WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) IF( .NOT.TSTERR )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9984 ) END IF WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9999 )THRESH WRITE( NOUT, FMT = * ) * * Read names of subroutines and flags which indicate * whether they are to be tested. * DO 20 I = 1, NSUBS LTEST( I ) = .FALSE. 20 CONTINUE 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT DO 40 I = 1, NSUBS IF( SNAMET.EQ.SNAMES( I ) ) $ GO TO 50 40 CONTINUE WRITE( NOUT, FMT = 9990 )SNAMET STOP 50 LTEST( I ) = LTESTT GO TO 30 * 60 CONTINUE CLOSE ( NIN ) * * Compute EPS (the machine precision). * EPS = RONE 70 CONTINUE IF( SDIFF( RONE + EPS, RONE ).EQ.RZERO ) $ GO TO 80 EPS = RHALF*EPS GO TO 70 80 CONTINUE EPS = EPS + EPS WRITE( NOUT, FMT = 9998 )EPS * * Check the reliability of CMMCH using exact data. * N = MIN( 32, NMAX ) DO 100 J = 1, N DO 90 I = 1, N AB( I, J ) = MAX( I - J + 1, 0 ) 90 CONTINUE AB( J, NMAX + 1 ) = J AB( 1, NMAX + J ) = J C( J, 1 ) = ZERO 100 CONTINUE DO 110 J = 1, N CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 110 CONTINUE * CC holds the exact result. On exit from CMMCH CT holds * the result computed by CMMCH. TRANSA = 'N' TRANSB = 'N' CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LCE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF TRANSB = 'C' CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LCE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF DO 120 J = 1, N AB( J, NMAX + 1 ) = N - J + 1 AB( 1, NMAX + J ) = N - J + 1 120 CONTINUE DO 130 J = 1, N CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - $ ( ( J + 1 )*J*( J - 1 ) )/3 130 CONTINUE TRANSA = 'C' TRANSB = 'N' CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LCE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF TRANSB = 'C' CALL CMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LCE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF * * Test each subroutine in turn. * DO 200 ISNUM = 1, NSUBS WRITE( NOUT, FMT = * ) IF( .NOT.LTEST( ISNUM ) )THEN * Subprogram is not to be tested. WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) ELSE SRNAMT = SNAMES( ISNUM ) * Test error exits. IF( TSTERR )THEN CALL CCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) WRITE( NOUT, FMT = * ) END IF * Test computations. INFOT = 0 OK = .TRUE. FATAL = .FALSE. GO TO ( 140, 150, 150, 160, 160, 170, 170, $ 180, 180 )ISNUM * Test CGEMM, 01. 140 CALL CCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test CHEMM, 02, CSYMM, 03. 150 CALL CCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test CTRMM, 04, CTRSM, 05. 160 CALL CCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) GO TO 190 * Test CHERK, 06, CSYRK, 07. 170 CALL CCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test CHER2K, 08, CSYR2K, 09. 180 CALL CCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 END IF 200 CONTINUE WRITE( NOUT, FMT = 9986 ) GO TO 230 * 210 CONTINUE WRITE( NOUT, FMT = 9985 ) GO TO 230 * 220 CONTINUE WRITE( NOUT, FMT = 9991 ) * 230 CONTINUE IF( TRACE ) $ CLOSE ( NTRA ) CLOSE ( NOUT ) STOP * 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', $ 'S THAN', F8.2 ) 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', $ 'THAN ', I2 ) 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) 9995 FORMAT( ' TESTS OF THE COMPLEX LEVEL 3 BLAS', //' THE F', $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 9994 FORMAT( ' FOR N ', 9I6 ) 9993 FORMAT( ' FOR ALPHA ', $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9992 FORMAT( ' FOR BETA ', $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', $ /' ******* TESTS ABANDONED *******' ) 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9989 FORMAT( ' ERROR IN CMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' CMMCH WAS CALLED WITH TRANSA = ', A1, $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) 9988 FORMAT( A6, L2 ) 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) * * End of CBLAT3. * END SUBROUTINE CCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests CGEMM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0, 0.0 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ) REAL G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX ALPHA, ALS, BETA, BLS REAL ERR, ERRMAX INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, $ MA, MB, MS, N, NA, NARGS, NB, NC, NS LOGICAL NULL, RESET, SAME, TRANA, TRANB CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB CHARACTER*3 ICH * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LCE, LCERES EXTERNAL LCE, LCERES * .. External Subroutines .. EXTERNAL CGEMM, CMAKE, CMMCH * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICH/'NTC'/ * .. Executable Statements .. * NARGS = 13 NC = 0 RESET = .TRUE. ERRMAX = RZERO * DO 110 IM = 1, NIDIM M = IDIM( IM ) * DO 100 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = M IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N NULL = N.LE.0.OR.M.LE.0 * DO 90 IK = 1, NIDIM K = IDIM( IK ) * DO 80 ICA = 1, 3 TRANSA = ICH( ICA: ICA ) TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' * IF( TRANA )THEN MA = K NA = M ELSE MA = M NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * * Generate the matrix A. * CALL CMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 70 ICB = 1, 3 TRANSB = ICH( ICB: ICB ) TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' * IF( TRANB )THEN MB = N NB = K ELSE MB = K NB = N END IF * Set LDB to 1 more than minimum value if room. LDB = MB IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 70 LBB = LDB*NB * * Generate the matrix B. * CALL CMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, $ LDB, RESET, ZERO ) * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL CMAKE( 'GE', ' ', ' ', M, N, C, NMAX, $ CC, LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * TRANAS = TRANSA TRANBS = TRANSB MS = M NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, $ BETA, LDC IF( REWI ) $ REWIND NTRA CALL CGEMM( TRANSA, TRANSB, M, N, K, ALPHA, $ AA, LDA, BB, LDB, BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 120 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = TRANSA.EQ.TRANAS ISAME( 2 ) = TRANSB.EQ.TRANBS ISAME( 3 ) = MS.EQ.M ISAME( 4 ) = NS.EQ.N ISAME( 5 ) = KS.EQ.K ISAME( 6 ) = ALS.EQ.ALPHA ISAME( 7 ) = LCE( AS, AA, LAA ) ISAME( 8 ) = LDAS.EQ.LDA ISAME( 9 ) = LCE( BS, BB, LBB ) ISAME( 10 ) = LDBS.EQ.LDB ISAME( 11 ) = BLS.EQ.BETA IF( NULL )THEN ISAME( 12 ) = LCE( CS, CC, LCC ) ELSE ISAME( 12 ) = LCERES( 'GE', ' ', M, N, CS, $ CC, LDC ) END IF ISAME( 13 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report * and return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF * IF( .NOT.NULL )THEN * * Check the result. * CALL CMMCH( TRANSA, TRANSB, M, N, K, $ ALPHA, A, NMAX, B, NMAX, BETA, $ C, NMAX, CT, G, CC, LDC, EPS, $ ERR, FATAL, NOUT, .TRUE. ) ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 120 END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 130 * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, $ ALPHA, LDA, LDB, BETA, LDC * 130 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of CCHK1. * END SUBROUTINE CCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests CHEMM and CSYMM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0, 0.0 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ) REAL G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX ALPHA, ALS, BETA, BLS REAL ERR, ERRMAX INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, $ NARGS, NC, NS LOGICAL CONJ, LEFT, NULL, RESET, SAME CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LCE, LCERES EXTERNAL LCE, LCERES * .. External Subroutines .. EXTERNAL CHEMM, CMAKE, CMMCH, CSYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. CONJ = SNAME( 2: 3 ).EQ.'HE' * NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = RZERO * DO 100 IM = 1, NIDIM M = IDIM( IM ) * DO 90 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = M IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 90 LCC = LDC*N NULL = N.LE.0.OR.M.LE.0 * Set LDB to 1 more than minimum value if room. LDB = M IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 90 LBB = LDB*N * * Generate the matrix B. * CALL CMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, $ ZERO ) * DO 80 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE.EQ.'L' * IF( LEFT )THEN NA = M ELSE NA = N END IF * Set LDA to 1 more than minimum value if room. LDA = NA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) * * Generate the hermitian or symmetric matrix A. * CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX, $ AA, LDA, RESET, ZERO ) * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL CMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, $ LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * SIDES = SIDE UPLOS = UPLO MS = M NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA IF( CONJ )THEN CALL CHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, $ BB, LDB, BETA, CC, LDC ) ELSE CALL CSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, $ BB, LDB, BETA, CC, LDC ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 110 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = SIDES.EQ.SIDE ISAME( 2 ) = UPLOS.EQ.UPLO ISAME( 3 ) = MS.EQ.M ISAME( 4 ) = NS.EQ.N ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LCE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = LCE( BS, BB, LBB ) ISAME( 9 ) = LDBS.EQ.LDB ISAME( 10 ) = BLS.EQ.BETA IF( NULL )THEN ISAME( 11 ) = LCE( CS, CC, LCC ) ELSE ISAME( 11 ) = LCERES( 'GE', ' ', M, N, CS, $ CC, LDC ) END IF ISAME( 12 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 110 END IF * IF( .NOT.NULL )THEN * * Check the result. * IF( LEFT )THEN CALL CMMCH( 'N', 'N', M, N, M, ALPHA, A, $ NMAX, B, NMAX, BETA, C, NMAX, $ CT, G, CC, LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL CMMCH( 'N', 'N', M, N, N, ALPHA, B, $ NMAX, A, NMAX, BETA, C, NMAX, $ CT, G, CC, LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 110 END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 120 * 110 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, $ LDB, BETA, LDC * 120 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, $ ',', F4.1, '), C,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of CCHK2. * END SUBROUTINE CCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, $ B, BB, BS, CT, G, C ) * * Tests CTRMM and CTRSM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CT( NMAX ) REAL G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX ALPHA, ALS REAL ERR, ERRMAX INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, $ NS LOGICAL LEFT, NULL, RESET, SAME CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, $ UPLOS CHARACTER*2 ICHD, ICHS, ICHU CHARACTER*3 ICHT * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LCE, LCERES EXTERNAL LCE, LCERES * .. External Subroutines .. EXTERNAL CMAKE, CMMCH, CTRMM, CTRSM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ * .. Executable Statements .. * NARGS = 11 NC = 0 RESET = .TRUE. ERRMAX = RZERO * Set up zero matrix for CMMCH. DO 20 J = 1, NMAX DO 10 I = 1, NMAX C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * DO 140 IM = 1, NIDIM M = IDIM( IM ) * DO 130 IN = 1, NIDIM N = IDIM( IN ) * Set LDB to 1 more than minimum value if room. LDB = M IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 130 LBB = LDB*N NULL = M.LE.0.OR.N.LE.0 * DO 120 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE.EQ.'L' IF( LEFT )THEN NA = M ELSE NA = N END IF * Set LDA to 1 more than minimum value if room. LDA = NA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 130 LAA = LDA*NA * DO 110 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) * DO 100 ICT = 1, 3 TRANSA = ICHT( ICT: ICT ) * DO 90 ICD = 1, 2 DIAG = ICHD( ICD: ICD ) * DO 80 IA = 1, NALF ALPHA = ALF( IA ) * * Generate the matrix A. * CALL CMAKE( 'TR', UPLO, DIAG, NA, NA, A, $ NMAX, AA, LDA, RESET, ZERO ) * * Generate the matrix B. * CALL CMAKE( 'GE', ' ', ' ', M, N, B, NMAX, $ BB, LDB, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * SIDES = SIDE UPLOS = UPLO TRANAS = TRANSA DIAGS = DIAG MS = M NS = N ALS = ALPHA DO 30 I = 1, LAA AS( I ) = AA( I ) 30 CONTINUE LDAS = LDA DO 40 I = 1, LBB BS( I ) = BB( I ) 40 CONTINUE LDBS = LDB * * Call the subroutine. * IF( SNAME( 4: 5 ).EQ.'MM' )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, $ LDA, LDB IF( REWI ) $ REWIND NTRA CALL CTRMM( SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, AA, LDA, BB, LDB ) ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, $ LDA, LDB IF( REWI ) $ REWIND NTRA CALL CTRSM( SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, AA, LDA, BB, LDB ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 150 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = SIDES.EQ.SIDE ISAME( 2 ) = UPLOS.EQ.UPLO ISAME( 3 ) = TRANAS.EQ.TRANSA ISAME( 4 ) = DIAGS.EQ.DIAG ISAME( 5 ) = MS.EQ.M ISAME( 6 ) = NS.EQ.N ISAME( 7 ) = ALS.EQ.ALPHA ISAME( 8 ) = LCE( AS, AA, LAA ) ISAME( 9 ) = LDAS.EQ.LDA IF( NULL )THEN ISAME( 10 ) = LCE( BS, BB, LBB ) ELSE ISAME( 10 ) = LCERES( 'GE', ' ', M, N, BS, $ BB, LDB ) END IF ISAME( 11 ) = LDBS.EQ.LDB * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 50 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 50 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 150 END IF * IF( .NOT.NULL )THEN IF( SNAME( 4: 5 ).EQ.'MM' )THEN * * Check the result. * IF( LEFT )THEN CALL CMMCH( TRANSA, 'N', M, N, M, $ ALPHA, A, NMAX, B, NMAX, $ ZERO, C, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL CMMCH( 'N', TRANSA, M, N, N, $ ALPHA, B, NMAX, A, NMAX, $ ZERO, C, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN * * Compute approximation to original * matrix. * DO 70 J = 1, N DO 60 I = 1, M C( I, J ) = BB( I + ( J - 1 )* $ LDB ) BB( I + ( J - 1 )*LDB ) = ALPHA* $ B( I, J ) 60 CONTINUE 70 CONTINUE * IF( LEFT )THEN CALL CMMCH( TRANSA, 'N', M, N, M, $ ONE, A, NMAX, C, NMAX, $ ZERO, B, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .FALSE. ) ELSE CALL CMMCH( 'N', TRANSA, M, N, N, $ ONE, C, NMAX, A, NMAX, $ ZERO, B, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .FALSE. ) END IF END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 150 END IF * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * 120 CONTINUE * 130 CONTINUE * 140 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 160 * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, LDA, LDB * 160 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', $ ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of CCHK3. * END SUBROUTINE CCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests CHERK and CSYRK. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0, 0.0 ) ) REAL RONE, RZERO PARAMETER ( RONE = 1.0, RZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ) REAL G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX ALPHA, ALS, BETA, BETS REAL ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, $ NARGS, NC, NS LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS CHARACTER*2 ICHT, ICHU * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LCE, LCERES EXTERNAL LCE, LCERES * .. External Subroutines .. EXTERNAL CHERK, CMAKE, CMMCH, CSYRK * .. Intrinsic Functions .. INTRINSIC CMPLX, MAX, REAL * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHT/'NC'/, ICHU/'UL'/ * .. Executable Statements .. CONJ = SNAME( 2: 3 ).EQ.'HE' * NARGS = 10 NC = 0 RESET = .TRUE. ERRMAX = RZERO * DO 100 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N * DO 90 IK = 1, NIDIM K = IDIM( IK ) * DO 80 ICT = 1, 2 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'C' IF( TRAN.AND..NOT.CONJ ) $ TRANS = 'T' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * * Generate the matrix A. * CALL CMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U' * DO 60 IA = 1, NALF ALPHA = ALF( IA ) IF( CONJ )THEN RALPHA = REAL( ALPHA ) ALPHA = CMPLX( RALPHA, RZERO ) END IF * DO 50 IB = 1, NBET BETA = BET( IB ) IF( CONJ )THEN RBETA = REAL( BETA ) BETA = CMPLX( RBETA, RZERO ) END IF NULL = N.LE.0 IF( CONJ ) $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. $ RZERO ).AND.RBETA.EQ.RONE ) * * Generate the matrix C. * CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, $ NMAX, CC, LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the subroutine. * UPLOS = UPLO TRANSS = TRANS NS = N KS = K IF( CONJ )THEN RALS = RALPHA ELSE ALS = ALPHA END IF DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA IF( CONJ )THEN RBETS = RBETA ELSE BETS = BETA END IF DO 20 I = 1, LCC CS( I ) = CC( I ) 20 CONTINUE LDCS = LDC * * Call the subroutine. * IF( CONJ )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, $ TRANS, N, K, RALPHA, LDA, RBETA, LDC IF( REWI ) $ REWIND NTRA CALL CHERK( UPLO, TRANS, N, K, RALPHA, AA, $ LDA, RBETA, CC, LDC ) ELSE IF( TRACE ) $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, BETA, LDC IF( REWI ) $ REWIND NTRA CALL CSYRK( UPLO, TRANS, N, K, ALPHA, AA, $ LDA, BETA, CC, LDC ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9992 ) FATAL = .TRUE. GO TO 120 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K IF( CONJ )THEN ISAME( 5 ) = RALS.EQ.RALPHA ELSE ISAME( 5 ) = ALS.EQ.ALPHA END IF ISAME( 6 ) = LCE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA IF( CONJ )THEN ISAME( 8 ) = RBETS.EQ.RBETA ELSE ISAME( 8 ) = BETS.EQ.BETA END IF IF( NULL )THEN ISAME( 9 ) = LCE( CS, CC, LCC ) ELSE ISAME( 9 ) = LCERES( SNAME( 2: 3 ), UPLO, N, $ N, CS, CC, LDC ) END IF ISAME( 10 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 30 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 30 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF * IF( .NOT.NULL )THEN * * Check the result column by column. * IF( CONJ )THEN TRANST = 'C' ELSE TRANST = 'T' END IF JC = 1 DO 40 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN CALL CMMCH( TRANST, 'N', LJ, 1, K, $ ALPHA, A( 1, JJ ), NMAX, $ A( 1, J ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL CMMCH( 'N', TRANST, LJ, 1, K, $ ALPHA, A( JJ, 1 ), NMAX, $ A( J, 1 ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 110 40 CONTINUE END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 130 * 110 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME IF( CONJ )THEN WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, RALPHA, $ LDA, RBETA, LDC ELSE WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, BETA, LDC END IF * 130 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, $ '), C,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of CCHK4. * END SUBROUTINE CCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) * * Tests CHER2K and CSYR2K. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) REAL RONE, RZERO PARAMETER ( RONE = 1.0, RZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ W( 2*NMAX ) REAL G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX ALPHA, ALS, BETA, BETS REAL ERR, ERRMAX, RBETA, RBETS INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS CHARACTER*2 ICHT, ICHU * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LCE, LCERES EXTERNAL LCE, LCERES * .. External Subroutines .. EXTERNAL CHER2K, CMAKE, CMMCH, CSYR2K * .. Intrinsic Functions .. INTRINSIC CMPLX, CONJG, MAX, REAL * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHT/'NC'/, ICHU/'UL'/ * .. Executable Statements .. CONJ = SNAME( 2: 3 ).EQ.'HE' * NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = RZERO * DO 130 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 130 LCC = LDC*N * DO 120 IK = 1, NIDIM K = IDIM( IK ) * DO 110 ICT = 1, 2 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'C' IF( TRAN.AND..NOT.CONJ ) $ TRANS = 'T' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 110 LAA = LDA*NA * * Generate the matrix A. * IF( TRAN )THEN CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, $ LDA, RESET, ZERO ) ELSE CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, $ RESET, ZERO ) END IF * * Generate the matrix B. * LDB = LDA LBB = LAA IF( TRAN )THEN CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), $ 2*NMAX, BB, LDB, RESET, ZERO ) ELSE CALL CMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), $ NMAX, BB, LDB, RESET, ZERO ) END IF * DO 100 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U' * DO 90 IA = 1, NALF ALPHA = ALF( IA ) * DO 80 IB = 1, NBET BETA = BET( IB ) IF( CONJ )THEN RBETA = REAL( BETA ) BETA = CMPLX( RBETA, RZERO ) END IF NULL = N.LE.0 IF( CONJ ) $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. $ ZERO ).AND.RBETA.EQ.RONE ) * * Generate the matrix C. * CALL CMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, $ NMAX, CC, LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the subroutine. * UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB IF( CONJ )THEN RBETS = RBETA ELSE BETS = BETA END IF DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( CONJ )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, LDB, RBETA, LDC IF( REWI ) $ REWIND NTRA CALL CHER2K( UPLO, TRANS, N, K, ALPHA, AA, $ LDA, BB, LDB, RBETA, CC, LDC ) ELSE IF( TRACE ) $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA CALL CSYR2K( UPLO, TRANS, N, K, ALPHA, AA, $ LDA, BB, LDB, BETA, CC, LDC ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9992 ) FATAL = .TRUE. GO TO 150 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LCE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = LCE( BS, BB, LBB ) ISAME( 9 ) = LDBS.EQ.LDB IF( CONJ )THEN ISAME( 10 ) = RBETS.EQ.RBETA ELSE ISAME( 10 ) = BETS.EQ.BETA END IF IF( NULL )THEN ISAME( 11 ) = LCE( CS, CC, LCC ) ELSE ISAME( 11 ) = LCERES( 'HE', UPLO, N, N, CS, $ CC, LDC ) END IF ISAME( 12 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 150 END IF * IF( .NOT.NULL )THEN * * Check the result column by column. * IF( CONJ )THEN TRANST = 'C' ELSE TRANST = 'T' END IF JJAB = 1 JC = 1 DO 70 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN DO 50 I = 1, K W( I ) = ALPHA*AB( ( J - 1 )*2* $ NMAX + K + I ) IF( CONJ )THEN W( K + I ) = CONJG( ALPHA )* $ AB( ( J - 1 )*2* $ NMAX + I ) ELSE W( K + I ) = ALPHA* $ AB( ( J - 1 )*2* $ NMAX + I ) END IF 50 CONTINUE CALL CMMCH( TRANST, 'N', LJ, 1, 2*K, $ ONE, AB( JJAB ), 2*NMAX, W, $ 2*NMAX, BETA, C( JJ, J ), $ NMAX, CT, G, CC( JC ), LDC, $ EPS, ERR, FATAL, NOUT, $ .TRUE. ) ELSE DO 60 I = 1, K IF( CONJ )THEN W( I ) = ALPHA*CONJG( AB( ( K + $ I - 1 )*NMAX + J ) ) W( K + I ) = CONJG( ALPHA* $ AB( ( I - 1 )*NMAX + $ J ) ) ELSE W( I ) = ALPHA*AB( ( K + I - 1 )* $ NMAX + J ) W( K + I ) = ALPHA* $ AB( ( I - 1 )*NMAX + $ J ) END IF 60 CONTINUE CALL CMMCH( 'N', 'N', LJ, 1, 2*K, ONE, $ AB( JJ ), NMAX, W, 2*NMAX, $ BETA, C( JJ, J ), NMAX, CT, $ G, CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 IF( TRAN ) $ JJAB = JJAB + 2*NMAX END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 140 70 CONTINUE END IF * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * 120 CONTINUE * 130 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 160 * 140 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME IF( CONJ )THEN WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, LDB, RBETA, LDC ELSE WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, LDB, BETA, LDC END IF * 160 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, $ ', C,', I3, ') .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, $ ',', F4.1, '), C,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of CCHK5. * END SUBROUTINE CCHKE( ISNUM, SRNAMT, NOUT ) * * Tests the error exits from the Level 3 Blas. * Requires a special version of the error-handling routine XERBLA. * ALPHA, RALPHA, BETA, RBETA, A, B and C should not need to be defined. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER ISNUM, NOUT CHARACTER*6 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Local Scalars .. COMPLEX ALPHA, BETA REAL RALPHA, RBETA * .. Local Arrays .. COMPLEX A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) * .. External Subroutines .. EXTERNAL CGEMM, CHEMM, CHER2K, CHERK, CHKXER, CSYMM, $ CSYR2K, CSYRK, CTRMM, CTRSM * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Executable Statements .. * OK is set to .FALSE. by the special version of XERBLA or by CHKXER * if anything is wrong. OK = .TRUE. * LERR is set to .TRUE. by the special version of XERBLA each time * it is called, and is then tested and re-set by CHKXER. LERR = .FALSE. GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, $ 90 )ISNUM 10 INFOT = 1 CALL CGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 CALL CGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 CALL CGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL CGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL CGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 20 INFOT = 1 CALL CHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 30 INFOT = 1 CALL CSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 40 INFOT = 1 CALL CTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 50 INFOT = 1 CALL CTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL CTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL CTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL CTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 60 INFOT = 1 CALL CHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 70 INFOT = 1 CALL CSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL CSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 80 INFOT = 1 CALL CHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 90 INFOT = 1 CALL CSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL CSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL CSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL CSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL CSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL CSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL CSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * 100 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT END IF RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of CCHKE. * END SUBROUTINE CMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, $ TRANSL ) * * Generates values for an M by N matrix A. * Stores the values in the array AA in the data structure required * by the routine, with unwanted elements set to rogue value. * * TYPE is 'GE', 'HE', 'SY' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX ZERO, ONE PARAMETER ( ZERO = ( 0.0, 0.0 ), ONE = ( 1.0, 0.0 ) ) COMPLEX ROGUE PARAMETER ( ROGUE = ( -1.0E10, 1.0E10 ) ) REAL RZERO PARAMETER ( RZERO = 0.0 ) REAL RROGUE PARAMETER ( RROGUE = -1.0E10 ) * .. Scalar Arguments .. COMPLEX TRANSL INTEGER LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO CHARACTER*2 TYPE * .. Array Arguments .. COMPLEX A( NMAX, * ), AA( * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J, JJ LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER * .. External Functions .. COMPLEX CBEG EXTERNAL CBEG * .. Intrinsic Functions .. INTRINSIC CMPLX, CONJG, REAL * .. Executable Statements .. GEN = TYPE.EQ.'GE' HER = TYPE.EQ.'HE' SYM = TYPE.EQ.'SY' TRI = TYPE.EQ.'TR' UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. * DO 20 J = 1, N DO 10 I = 1, M IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) $ THEN A( I, J ) = CBEG( RESET ) + TRANSL IF( I.NE.J )THEN * Set some elements to zero IF( N.GT.3.AND.J.EQ.N/2 ) $ A( I, J ) = ZERO IF( HER )THEN A( J, I ) = CONJG( A( I, J ) ) ELSE IF( SYM )THEN A( J, I ) = A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF END IF END IF 10 CONTINUE IF( HER ) $ A( J, J ) = CMPLX( REAL( A( J, J ) ), RZERO ) IF( TRI ) $ A( J, J ) = A( J, J ) + ONE IF( UNIT ) $ A( J, J ) = ONE 20 CONTINUE * * Store elements in array AS in data structure required by routine. * IF( TYPE.EQ.'GE' )THEN DO 50 J = 1, N DO 30 I = 1, M AA( I + ( J - 1 )*LDA ) = A( I, J ) 30 CONTINUE DO 40 I = M + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 40 CONTINUE 50 CONTINUE ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 IF( UNIT )THEN IEND = J - 1 ELSE IEND = J END IF ELSE IF( UNIT )THEN IBEG = J + 1 ELSE IBEG = J END IF IEND = N END IF DO 60 I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE 60 CONTINUE DO 70 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I, J ) 70 CONTINUE DO 80 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 80 CONTINUE IF( HER )THEN JJ = J + ( J - 1 )*LDA AA( JJ ) = CMPLX( REAL( AA( JJ ) ), RROGUE ) END IF 90 CONTINUE END IF RETURN * * End of CMAKE. * END SUBROUTINE CMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, $ NOUT, MV ) * * Checks the results of the computational tests. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0, 0.0 ) ) REAL RZERO, RONE PARAMETER ( RZERO = 0.0, RONE = 1.0 ) * .. Scalar Arguments .. COMPLEX ALPHA, BETA REAL EPS, ERR INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT LOGICAL FATAL, MV CHARACTER*1 TRANSA, TRANSB * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ), $ CC( LDCC, * ), CT( * ) REAL G( * ) * .. Local Scalars .. COMPLEX CL REAL ERRI INTEGER I, J, K LOGICAL CTRANA, CTRANB, TRANA, TRANB * .. Intrinsic Functions .. INTRINSIC ABS, AIMAG, CONJG, MAX, REAL, SQRT * .. Statement Functions .. REAL ABS1 * .. Statement Function definitions .. ABS1( CL ) = ABS( REAL( CL ) ) + ABS( AIMAG( CL ) ) * .. Executable Statements .. TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' CTRANA = TRANSA.EQ.'C' CTRANB = TRANSB.EQ.'C' * * Compute expected result, one column at a time, in CT using data * in A, B and C. * Compute gauges in G. * DO 220 J = 1, N * DO 10 I = 1, M CT( I ) = ZERO G( I ) = RZERO 10 CONTINUE IF( .NOT.TRANA.AND..NOT.TRANB )THEN DO 30 K = 1, KK DO 20 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( K, J ) G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) 20 CONTINUE 30 CONTINUE ELSE IF( TRANA.AND..NOT.TRANB )THEN IF( CTRANA )THEN DO 50 K = 1, KK DO 40 I = 1, M CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( K, J ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( K, J ) ) 40 CONTINUE 50 CONTINUE ELSE DO 70 K = 1, KK DO 60 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( K, J ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( K, J ) ) 60 CONTINUE 70 CONTINUE END IF ELSE IF( .NOT.TRANA.AND.TRANB )THEN IF( CTRANB )THEN DO 90 K = 1, KK DO 80 I = 1, M CT( I ) = CT( I ) + A( I, K )*CONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( I, K ) )* $ ABS1( B( J, K ) ) 80 CONTINUE 90 CONTINUE ELSE DO 110 K = 1, KK DO 100 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( J, K ) G( I ) = G( I ) + ABS1( A( I, K ) )* $ ABS1( B( J, K ) ) 100 CONTINUE 110 CONTINUE END IF ELSE IF( TRANA.AND.TRANB )THEN IF( CTRANA )THEN IF( CTRANB )THEN DO 130 K = 1, KK DO 120 I = 1, M CT( I ) = CT( I ) + CONJG( A( K, I ) )* $ CONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( J, K ) ) 120 CONTINUE 130 CONTINUE ELSE DO 150 K = 1, KK DO 140 I = 1, M CT( I ) = CT( I ) + CONJG( A( K, I ) )*B( J, K ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( J, K ) ) 140 CONTINUE 150 CONTINUE END IF ELSE IF( CTRANB )THEN DO 170 K = 1, KK DO 160 I = 1, M CT( I ) = CT( I ) + A( K, I )*CONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( J, K ) ) 160 CONTINUE 170 CONTINUE ELSE DO 190 K = 1, KK DO 180 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( J, K ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( J, K ) ) 180 CONTINUE 190 CONTINUE END IF END IF END IF DO 200 I = 1, M CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) G( I ) = ABS1( ALPHA )*G( I ) + $ ABS1( BETA )*ABS1( C( I, J ) ) 200 CONTINUE * * Compute the error ratio for this result. * ERR = ZERO DO 210 I = 1, M ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS IF( G( I ).NE.RZERO ) $ ERRI = ERRI/G( I ) ERR = MAX( ERR, ERRI ) IF( ERR*SQRT( EPS ).GE.RONE ) $ GO TO 230 210 CONTINUE * 220 CONTINUE * * If the loop completes, all results are at least half accurate. GO TO 250 * * Report fatal error. * 230 FATAL = .TRUE. WRITE( NOUT, FMT = 9999 ) DO 240 I = 1, M IF( MV )THEN WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) ELSE WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) END IF 240 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9997 )J * 250 CONTINUE RETURN * 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', $ 'F ACCURATE *******', /' EXPECTED RE', $ 'SULT COMPUTED RESULT' ) 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) * * End of CMMCH. * END LOGICAL FUNCTION LCE( RI, RJ, LR ) * * Tests if two arrays are identical. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER LR * .. Array Arguments .. COMPLEX RI( * ), RJ( * ) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 10 I = 1, LR IF( RI( I ).NE.RJ( I ) ) $ GO TO 20 10 CONTINUE LCE = .TRUE. GO TO 30 20 CONTINUE LCE = .FALSE. 30 RETURN * * End of LCE. * END LOGICAL FUNCTION LCERES( TYPE, UPLO, M, N, AA, AS, LDA ) * * Tests if selected elements in two arrays are equal. * * TYPE is 'GE' or 'HE' or 'SY'. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER LDA, M, N CHARACTER*1 UPLO CHARACTER*2 TYPE * .. Array Arguments .. COMPLEX AA( LDA, * ), AS( LDA, * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J LOGICAL UPPER * .. Executable Statements .. UPPER = UPLO.EQ.'U' IF( TYPE.EQ.'GE' )THEN DO 20 J = 1, N DO 10 I = M + 1, LDA IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 10 CONTINUE 20 CONTINUE ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY' )THEN DO 50 J = 1, N IF( UPPER )THEN IBEG = 1 IEND = J ELSE IBEG = J IEND = N END IF DO 30 I = 1, IBEG - 1 IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 30 CONTINUE DO 40 I = IEND + 1, LDA IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 40 CONTINUE 50 CONTINUE END IF * 60 CONTINUE LCERES = .TRUE. GO TO 80 70 CONTINUE LCERES = .FALSE. 80 RETURN * * End of LCERES. * END COMPLEX FUNCTION CBEG( RESET ) * * Generates complex numbers as pairs of random numbers uniformly * distributed between -0.5 and 0.5. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. LOGICAL RESET * .. Local Scalars .. INTEGER I, IC, J, MI, MJ * .. Save statement .. SAVE I, IC, J, MI, MJ * .. Intrinsic Functions .. INTRINSIC CMPLX * .. Executable Statements .. IF( RESET )THEN * Initialize local variables. MI = 891 MJ = 457 I = 7 J = 7 IC = 0 RESET = .FALSE. END IF * * The sequence of values of I or J is bounded between 1 and 999. * If initial I or J = 1,2,3,6,7 or 9, the period will be 50. * If initial I or J = 4 or 8, the period will be 25. * If initial I or J = 5, the period will be 10. * IC is used to break up the period by skipping 1 value of I or J * in 6. * IC = IC + 1 10 I = I*MI J = J*MJ I = I - 1000*( I/1000 ) J = J - 1000*( J/1000 ) IF( IC.GE.5 )THEN IC = 0 GO TO 10 END IF CBEG = CMPLX( ( I - 500 )/1001.0, ( J - 500 )/1001.0 ) RETURN * * End of CBEG. * END REAL FUNCTION SDIFF( X, Y ) * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. REAL X, Y * .. Executable Statements .. SDIFF = X - Y RETURN * * End of SDIFF. * END SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * * Tests whether XERBLA has detected an error when it should. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT OK = .FALSE. END IF LERR = .FALSE. RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', $ 'ETECTED BY ', A6, ' *****' ) * * End of CHKXER. * END SUBROUTINE XERBLA( SRNAME, INFO ) * * This is a special version of XERBLA to be used only as part of * the test program for testing error exits from the Level 3 BLAS * routines. * * XERBLA is an error handler for the Level 3 BLAS routines. * * It is called by the Level 3 BLAS routines if an input parameter is * invalid. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER INFO CHARACTER*6 SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT * .. Executable Statements .. LERR = .TRUE. IF( INFO.NE.INFOT )THEN IF( INFOT.NE.0 )THEN WRITE( NOUT, FMT = 9999 )INFO, INFOT ELSE WRITE( NOUT, FMT = 9997 )INFO END IF OK = .FALSE. END IF IF( SRNAME.NE.SRNAMT )THEN WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT OK = .FALSE. END IF RETURN * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', $ 'AD OF ', A6, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check if test -f 'dblat3.f' then echo shar: will not over-write existing file "'dblat3.f'" else cat << SHAR_EOF > 'dblat3.f' PROGRAM DBLAT3 * * Test program for the DOUBLE PRECISION Level 3 Blas. * * The program must be driven by a short data file. The first 14 records * of the file are read using list-directed input, the last 6 records * are read using the format ( A6, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the * following 20 lines: * 'DBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE * 6 UNIT NUMBER OF SUMMARY FILE * 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. * F LOGICAL FLAG, T TO STOP ON FAILURES. * T LOGICAL FLAG, T TO TEST ERROR EXITS. * 16.0 THRESHOLD VALUE OF TEST RATIO * 6 NUMBER OF VALUES OF N * 0 1 2 3 5 9 VALUES OF N * 3 NUMBER OF VALUES OF ALPHA * 0.0 1.0 0.7 VALUES OF ALPHA * 3 NUMBER OF VALUES OF BETA * 0.0 1.0 1.3 VALUES OF BETA * DGEMM T PUT F FOR NO TEST. SAME COLUMNS. * DSYMM T PUT F FOR NO TEST. SAME COLUMNS. * DTRMM T PUT F FOR NO TEST. SAME COLUMNS. * DTRSM T PUT F FOR NO TEST. SAME COLUMNS. * DSYRK T PUT F FOR NO TEST. SAME COLUMNS. * DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. * * See: * * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. * A Set of Level 3 Basic Linear Algebra Subprograms. * * Technical Memorandum No.88 (Revision 1), Mathematics and * Computer Science Division, Argonne National Laboratory, 9700 * South Cass Avenue, Argonne, Illinois 60439, US. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS PARAMETER ( NSUBS = 6 ) DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 ) INTEGER NMAX PARAMETER ( NMAX = 248 ) INTEGER NIDMAX, NALMAX, NBEMAX * PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) PARAMETER ( NIDMAX = 20, NALMAX = 7, NBEMAX = 7 ) * .. Local Scalars .. DOUBLE PRECISION EPS, ERR, THRESH INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB CHARACTER*6 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), $ ALF( NALMAX ), AS( NMAX*NMAX ), $ BB( NMAX*NMAX ), BET( NBEMAX ), $ BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) CHARACTER*6 SNAMES( NSUBS ) * .. External Functions .. DOUBLE PRECISION DDIFF LOGICAL LDE EXTERNAL DDIFF, LDE * .. External Subroutines .. EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHKE, DMMCH * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ', $ 'DSYRK ', 'DSYR2K'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT * OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. * READ( NIN, FMT = * )SNAPS READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI REWI = REWI.AND.TRACE * Read the flag that directs stopping on any failure. READ( NIN, FMT = * )SFATAL * Read the flag that indicates whether error exits are to be tested. READ( NIN, FMT = * )TSTERR * Read the threshold value of the test ratio READ( NIN, FMT = * )THRESH * * Read and check the parameter values for the tests. * * Values of N READ( NIN, FMT = * )NIDIM IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN WRITE( NOUT, FMT = 9997 )'N', NIDMAX GO TO 220 END IF READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) DO 10 I = 1, NIDIM IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN WRITE( NOUT, FMT = 9996 )NMAX GO TO 220 END IF 10 CONTINUE * Values of ALPHA READ( NIN, FMT = * )NALF IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX GO TO 220 END IF READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) * Values of BETA READ( NIN, FMT = * )NBET IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX GO TO 220 END IF READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) * * Report values of parameters. * WRITE( NOUT, FMT = 9995 ) WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) IF( .NOT.TSTERR )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9984 ) END IF WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9999 )THRESH WRITE( NOUT, FMT = * ) * * Read names of subroutines and flags which indicate * whether they are to be tested. * DO 20 I = 1, NSUBS LTEST( I ) = .FALSE. 20 CONTINUE 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT DO 40 I = 1, NSUBS IF( SNAMET.EQ.SNAMES( I ) ) $ GO TO 50 40 CONTINUE WRITE( NOUT, FMT = 9990 )SNAMET STOP 50 LTEST( I ) = LTESTT GO TO 30 * 60 CONTINUE CLOSE ( NIN ) * * Compute EPS (the machine precision). * EPS = ONE 70 CONTINUE IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO ) $ GO TO 80 EPS = HALF*EPS GO TO 70 80 CONTINUE EPS = EPS + EPS WRITE( NOUT, FMT = 9998 )EPS * * Check the reliability of DMMCH using exact data. * N = MIN( 32, NMAX ) DO 100 J = 1, N DO 90 I = 1, N AB( I, J ) = MAX( I - J + 1, 0 ) 90 CONTINUE AB( J, NMAX + 1 ) = J AB( 1, NMAX + J ) = J C( J, 1 ) = ZERO 100 CONTINUE DO 110 J = 1, N CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 110 CONTINUE * CC holds the exact result. On exit from DMMCH CT holds * the result computed by DMMCH. TRANSA = 'N' TRANSB = 'N' CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LDE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF TRANSB = 'T' CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LDE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF DO 120 J = 1, N AB( J, NMAX + 1 ) = N - J + 1 AB( 1, NMAX + J ) = N - J + 1 120 CONTINUE DO 130 J = 1, N CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - $ ( ( J + 1 )*J*( J - 1 ) )/3 130 CONTINUE TRANSA = 'T' TRANSB = 'N' CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LDE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF TRANSB = 'T' CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LDE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF * * Test each subroutine in turn. * DO 200 ISNUM = 1, NSUBS WRITE( NOUT, FMT = * ) IF( .NOT.LTEST( ISNUM ) )THEN * Subprogram is not to be tested. WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) ELSE SRNAMT = SNAMES( ISNUM ) * Test error exits. IF( TSTERR )THEN CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) WRITE( NOUT, FMT = * ) END IF * Test computations. INFOT = 0 OK = .TRUE. FATAL = .FALSE. GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM * Test DGEMM, 01. 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test DSYMM, 02. 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test DTRMM, 03, DTRSM, 04. 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) GO TO 190 * Test DSYRK, 05. 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test DSYR2K, 06. 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 END IF 200 CONTINUE WRITE( NOUT, FMT = 9986 ) GO TO 230 * 210 CONTINUE WRITE( NOUT, FMT = 9985 ) GO TO 230 * 220 CONTINUE WRITE( NOUT, FMT = 9991 ) * 230 CONTINUE IF( TRACE ) $ CLOSE ( NTRA ) CLOSE ( NOUT ) STOP * 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', $ 'S THAN', F8.2 ) 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', $ 'THAN ', I2 ) 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) 9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F', $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 9994 FORMAT( ' FOR N ', 9I6 ) 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) 9992 FORMAT( ' FOR BETA ', 7F6.1 ) 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', $ /' ******* TESTS ABANDONED *******' ) 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1, $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) 9988 FORMAT( A6, L2 ) 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) * * End of DBLAT3. * END SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests DGEMM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, $ MA, MB, MS, N, NA, NARGS, NB, NC, NS LOGICAL NULL, RESET, SAME, TRANA, TRANB CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB CHARACTER*3 ICH * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. EXTERNAL DGEMM, DMAKE, DMMCH * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICH/'NTC'/ * .. Executable Statements .. * NARGS = 13 NC = 0 RESET = .TRUE. ERRMAX = ZERO * DO 110 IM = 1, NIDIM M = IDIM( IM ) * DO 100 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = M IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N NULL = N.LE.0.OR.M.LE.0 * DO 90 IK = 1, NIDIM K = IDIM( IK ) * DO 80 ICA = 1, 3 TRANSA = ICH( ICA: ICA ) TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' * IF( TRANA )THEN MA = K NA = M ELSE MA = M NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * * Generate the matrix A. * CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 70 ICB = 1, 3 TRANSB = ICH( ICB: ICB ) TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' * IF( TRANB )THEN MB = N NB = K ELSE MB = K NB = N END IF * Set LDB to 1 more than minimum value if room. LDB = MB IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 70 LBB = LDB*NB * * Generate the matrix B. * CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, $ LDB, RESET, ZERO ) * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, $ CC, LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * TRANAS = TRANSA TRANBS = TRANSB MS = M NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, $ BETA, LDC IF( REWI ) $ REWIND NTRA CALL DGEMM( TRANSA, TRANSB, M, N, K, ALPHA, $ AA, LDA, BB, LDB, BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 120 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = TRANSA.EQ.TRANAS ISAME( 2 ) = TRANSB.EQ.TRANBS ISAME( 3 ) = MS.EQ.M ISAME( 4 ) = NS.EQ.N ISAME( 5 ) = KS.EQ.K ISAME( 6 ) = ALS.EQ.ALPHA ISAME( 7 ) = LDE( AS, AA, LAA ) ISAME( 8 ) = LDAS.EQ.LDA ISAME( 9 ) = LDE( BS, BB, LBB ) ISAME( 10 ) = LDBS.EQ.LDB ISAME( 11 ) = BLS.EQ.BETA IF( NULL )THEN ISAME( 12 ) = LDE( CS, CC, LCC ) ELSE ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS, $ CC, LDC ) END IF ISAME( 13 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report * and return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF * IF( .NOT.NULL )THEN * * Check the result. * CALL DMMCH( TRANSA, TRANSB, M, N, K, $ ALPHA, A, NMAX, B, NMAX, BETA, $ C, NMAX, CT, G, CC, LDC, EPS, $ ERR, FATAL, NOUT, .TRUE. ) ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 120 END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 130 * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, $ ALPHA, LDA, LDB, BETA, LDC * 130 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', $ 'C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of DCHK1. * END SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests DSYMM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, $ NARGS, NC, NS LOGICAL LEFT, NULL, RESET, SAME CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. EXTERNAL DMAKE, DMMCH, DSYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. * NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = ZERO * DO 100 IM = 1, NIDIM M = IDIM( IM ) * DO 90 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = M IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 90 LCC = LDC*N NULL = N.LE.0.OR.M.LE.0 * * Set LDB to 1 more than minimum value if room. LDB = M IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 90 LBB = LDB*N * * Generate the matrix B. * CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, $ ZERO ) * DO 80 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE.EQ.'L' * IF( LEFT )THEN NA = M ELSE NA = N END IF * Set LDA to 1 more than minimum value if room. LDA = NA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) * * Generate the symmetric matrix A. * CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, $ LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * SIDES = SIDE UPLOS = UPLO MS = M NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, $ BB, LDB, BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 110 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = SIDES.EQ.SIDE ISAME( 2 ) = UPLOS.EQ.UPLO ISAME( 3 ) = MS.EQ.M ISAME( 4 ) = NS.EQ.N ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LDE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = LDE( BS, BB, LBB ) ISAME( 9 ) = LDBS.EQ.LDB ISAME( 10 ) = BLS.EQ.BETA IF( NULL )THEN ISAME( 11 ) = LDE( CS, CC, LCC ) ELSE ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS, $ CC, LDC ) END IF ISAME( 12 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 110 END IF * IF( .NOT.NULL )THEN * * Check the result. * IF( LEFT )THEN CALL DMMCH( 'N', 'N', M, N, M, ALPHA, A, $ NMAX, B, NMAX, BETA, C, NMAX, $ CT, G, CC, LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL DMMCH( 'N', 'N', M, N, N, ALPHA, B, $ NMAX, A, NMAX, BETA, C, NMAX, $ CT, G, CC, LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 110 END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 120 * 110 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, $ LDB, BETA, LDC * 120 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of DCHK2. * END SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, $ B, BB, BS, CT, G, C ) * * Tests DTRMM and DTRSM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, $ NS LOGICAL LEFT, NULL, RESET, SAME CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, $ UPLOS CHARACTER*2 ICHD, ICHS, ICHU CHARACTER*3 ICHT * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. EXTERNAL DMAKE, DMMCH, DTRMM, DTRSM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ * .. Executable Statements .. * NARGS = 11 NC = 0 RESET = .TRUE. ERRMAX = ZERO * Set up zero matrix for DMMCH. DO 20 J = 1, NMAX DO 10 I = 1, NMAX C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * DO 140 IM = 1, NIDIM M = IDIM( IM ) * DO 130 IN = 1, NIDIM N = IDIM( IN ) * Set LDB to 1 more than minimum value if room. LDB = M IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 130 LBB = LDB*N NULL = M.LE.0.OR.N.LE.0 * DO 120 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE.EQ.'L' IF( LEFT )THEN NA = M ELSE NA = N END IF * Set LDA to 1 more than minimum value if room. LDA = NA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 130 LAA = LDA*NA * DO 110 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) * DO 100 ICT = 1, 3 TRANSA = ICHT( ICT: ICT ) * DO 90 ICD = 1, 2 DIAG = ICHD( ICD: ICD ) * DO 80 IA = 1, NALF ALPHA = ALF( IA ) * * Generate the matrix A. * CALL DMAKE( 'TR', UPLO, DIAG, NA, NA, A, $ NMAX, AA, LDA, RESET, ZERO ) * * Generate the matrix B. * CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, $ BB, LDB, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * SIDES = SIDE UPLOS = UPLO TRANAS = TRANSA DIAGS = DIAG MS = M NS = N ALS = ALPHA DO 30 I = 1, LAA AS( I ) = AA( I ) 30 CONTINUE LDAS = LDA DO 40 I = 1, LBB BS( I ) = BB( I ) 40 CONTINUE LDBS = LDB * * Call the subroutine. * IF( SNAME( 4: 5 ).EQ.'MM' )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, $ LDA, LDB IF( REWI ) $ REWIND NTRA CALL DTRMM( SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, AA, LDA, BB, LDB ) ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, $ LDA, LDB IF( REWI ) $ REWIND NTRA CALL DTRSM( SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, AA, LDA, BB, LDB ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 150 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = SIDES.EQ.SIDE ISAME( 2 ) = UPLOS.EQ.UPLO ISAME( 3 ) = TRANAS.EQ.TRANSA ISAME( 4 ) = DIAGS.EQ.DIAG ISAME( 5 ) = MS.EQ.M ISAME( 6 ) = NS.EQ.N ISAME( 7 ) = ALS.EQ.ALPHA ISAME( 8 ) = LDE( AS, AA, LAA ) ISAME( 9 ) = LDAS.EQ.LDA IF( NULL )THEN ISAME( 10 ) = LDE( BS, BB, LBB ) ELSE ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS, $ BB, LDB ) END IF ISAME( 11 ) = LDBS.EQ.LDB * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 50 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 50 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 150 END IF * IF( .NOT.NULL )THEN IF( SNAME( 4: 5 ).EQ.'MM' )THEN * * Check the result. * IF( LEFT )THEN CALL DMMCH( TRANSA, 'N', M, N, M, $ ALPHA, A, NMAX, B, NMAX, $ ZERO, C, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL DMMCH( 'N', TRANSA, M, N, N, $ ALPHA, B, NMAX, A, NMAX, $ ZERO, C, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN * * Compute approximation to original * matrix. * DO 70 J = 1, N DO 60 I = 1, M C( I, J ) = BB( I + ( J - 1 )* $ LDB ) BB( I + ( J - 1 )*LDB ) = ALPHA* $ B( I, J ) 60 CONTINUE 70 CONTINUE * IF( LEFT )THEN CALL DMMCH( TRANSA, 'N', M, N, M, $ ONE, A, NMAX, C, NMAX, $ ZERO, B, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .FALSE. ) ELSE CALL DMMCH( 'N', TRANSA, M, N, N, $ ONE, C, NMAX, A, NMAX, $ ZERO, B, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .FALSE. ) END IF END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 150 END IF * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * 120 CONTINUE * 130 CONTINUE * 140 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 160 * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, LDA, LDB * 160 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of DCHK3. * END SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests DSYRK. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, $ NARGS, NC, NS LOGICAL NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. EXTERNAL DMAKE, DMMCH, DSYRK * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * NARGS = 10 NC = 0 RESET = .TRUE. ERRMAX = ZERO * DO 100 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N NULL = N.LE.0 * DO 90 IK = 1, NIDIM K = IDIM( IK ) * DO 80 ICT = 1, 3 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * * Generate the matrix A. * CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U' * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, $ LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the subroutine. * UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA BETS = BETA DO 20 I = 1, LCC CS( I ) = CC( I ) 20 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, BETA, LDC IF( REWI ) $ REWIND NTRA CALL DSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, $ BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9993 ) FATAL = .TRUE. GO TO 120 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LDE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = BETS.EQ.BETA IF( NULL )THEN ISAME( 9 ) = LDE( CS, CC, LCC ) ELSE ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS, $ CC, LDC ) END IF ISAME( 10 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 30 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 30 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF * IF( .NOT.NULL )THEN * * Check the result column by column. * JC = 1 DO 40 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN CALL DMMCH( 'T', 'N', LJ, 1, K, ALPHA, $ A( 1, JJ ), NMAX, $ A( 1, J ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL DMMCH( 'N', 'T', LJ, 1, K, ALPHA, $ A( JJ, 1 ), NMAX, $ A( J, 1 ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 110 40 CONTINUE END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 130 * 110 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, BETA, LDC * 130 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of DCHK4. * END SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) * * Tests DSYR2K. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS LOGICAL NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LDE, LDERES EXTERNAL LDE, LDERES * .. External Subroutines .. EXTERNAL DMAKE, DMMCH, DSYR2K * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = ZERO * DO 130 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 130 LCC = LDC*N NULL = N.LE.0 * DO 120 IK = 1, NIDIM K = IDIM( IK ) * DO 110 ICT = 1, 3 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 110 LAA = LDA*NA * * Generate the matrix A. * IF( TRAN )THEN CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, $ LDA, RESET, ZERO ) ELSE CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, $ RESET, ZERO ) END IF * * Generate the matrix B. * LDB = LDA LBB = LAA IF( TRAN )THEN CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), $ 2*NMAX, BB, LDB, RESET, ZERO ) ELSE CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), $ NMAX, BB, LDB, RESET, ZERO ) END IF * DO 100 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U' * DO 90 IA = 1, NALF ALPHA = ALF( IA ) * DO 80 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, $ LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the subroutine. * UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BETS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, $ BB, LDB, BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9993 ) FATAL = .TRUE. GO TO 150 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LDE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = LDE( BS, BB, LBB ) ISAME( 9 ) = LDBS.EQ.LDB ISAME( 10 ) = BETS.EQ.BETA IF( NULL )THEN ISAME( 11 ) = LDE( CS, CC, LCC ) ELSE ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS, $ CC, LDC ) END IF ISAME( 12 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 150 END IF * IF( .NOT.NULL )THEN * * Check the result column by column. * JJAB = 1 JC = 1 DO 70 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN DO 50 I = 1, K W( I ) = AB( ( J - 1 )*2*NMAX + K + $ I ) W( K + I ) = AB( ( J - 1 )*2*NMAX + $ I ) 50 CONTINUE CALL DMMCH( 'T', 'N', LJ, 1, 2*K, $ ALPHA, AB( JJAB ), 2*NMAX, $ W, 2*NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE DO 60 I = 1, K W( I ) = AB( ( K + I - 1 )*NMAX + $ J ) W( K + I ) = AB( ( I - 1 )*NMAX + $ J ) 60 CONTINUE CALL DMMCH( 'N', 'N', LJ, 1, 2*K, $ ALPHA, AB( JJ ), NMAX, W, $ 2*NMAX, BETA, C( JJ, J ), $ NMAX, CT, G, CC( JC ), LDC, $ EPS, ERR, FATAL, NOUT, $ .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 IF( TRAN ) $ JJAB = JJAB + 2*NMAX END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 140 70 CONTINUE END IF * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * 120 CONTINUE * 130 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 160 * 140 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, LDB, BETA, LDC * 160 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of DCHK5. * END SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT ) * * Tests the error exits from the Level 3 Blas. * Requires a special version of the error-handling routine XERBLA. * ALPHA, BETA, A, B and C should not need to be defined. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER ISNUM, NOUT CHARACTER*6 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Local Scalars .. DOUBLE PRECISION ALPHA, BETA * .. Local Arrays .. DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) * .. External Subroutines .. EXTERNAL CHKXER, DGEMM, DSYMM, DSYR2K, DSYRK, DTRMM, $ DTRSM * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Executable Statements .. * OK is set to .FALSE. by the special version of XERBLA or by CHKXER * if anything is wrong. OK = .TRUE. * LERR is set to .TRUE. by the special version of XERBLA each time * it is called, and is then tested and re-set by CHKXER. LERR = .FALSE. GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM 10 INFOT = 1 CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 CALL DGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL DGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL DGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 20 INFOT = 1 CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 30 INFOT = 1 CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 40 INFOT = 1 CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL DTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL DTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 50 INFOT = 1 CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 60 INFOT = 1 CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL DSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL DSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL DSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * 70 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT END IF RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of DCHKE. * END SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, $ TRANSL ) * * Generates values for an M by N matrix A. * Stores the values in the array AA in the data structure required * by the routine, with unwanted elements set to rogue value. * * TYPE is 'GE', 'SY' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) DOUBLE PRECISION ROGUE PARAMETER ( ROGUE = -1.0D10 ) * .. Scalar Arguments .. DOUBLE PRECISION TRANSL INTEGER LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO CHARACTER*2 TYPE * .. Array Arguments .. DOUBLE PRECISION A( NMAX, * ), AA( * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER * .. External Functions .. DOUBLE PRECISION DBEG EXTERNAL DBEG * .. Executable Statements .. GEN = TYPE.EQ.'GE' SYM = TYPE.EQ.'SY' TRI = TYPE.EQ.'TR' UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. * DO 20 J = 1, N DO 10 I = 1, M IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) $ THEN A( I, J ) = DBEG( RESET ) + TRANSL IF( I.NE.J )THEN * Set some elements to zero IF( N.GT.3.AND.J.EQ.N/2 ) $ A( I, J ) = ZERO IF( SYM )THEN A( J, I ) = A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF END IF END IF 10 CONTINUE IF( TRI ) $ A( J, J ) = A( J, J ) + ONE IF( UNIT ) $ A( J, J ) = ONE 20 CONTINUE * * Store elements in array AS in data structure required by routine. * IF( TYPE.EQ.'GE' )THEN DO 50 J = 1, N DO 30 I = 1, M AA( I + ( J - 1 )*LDA ) = A( I, J ) 30 CONTINUE DO 40 I = M + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 40 CONTINUE 50 CONTINUE ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 IF( UNIT )THEN IEND = J - 1 ELSE IEND = J END IF ELSE IF( UNIT )THEN IBEG = J + 1 ELSE IBEG = J END IF IEND = N END IF DO 60 I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE 60 CONTINUE DO 70 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I, J ) 70 CONTINUE DO 80 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 80 CONTINUE 90 CONTINUE END IF RETURN * * End of DMAKE. * END SUBROUTINE DMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, $ NOUT, MV ) * * Checks the results of the computational tests. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. DOUBLE PRECISION ZERO, ONE PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA, EPS, ERR INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT LOGICAL FATAL, MV CHARACTER*1 TRANSA, TRANSB * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ), $ CC( LDCC, * ), CT( * ), G( * ) * .. Local Scalars .. DOUBLE PRECISION ERRI INTEGER I, J, K LOGICAL TRANA, TRANB * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. Executable Statements .. TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' * * Compute expected result, one column at a time, in CT using data * in A, B and C. * Compute gauges in G. * DO 120 J = 1, N * DO 10 I = 1, M CT( I ) = ZERO G( I ) = ZERO 10 CONTINUE IF( .NOT.TRANA.AND..NOT.TRANB )THEN DO 30 K = 1, KK DO 20 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( K, J ) G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) 20 CONTINUE 30 CONTINUE ELSE IF( TRANA.AND..NOT.TRANB )THEN DO 50 K = 1, KK DO 40 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( K, J ) G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) 40 CONTINUE 50 CONTINUE ELSE IF( .NOT.TRANA.AND.TRANB )THEN DO 70 K = 1, KK DO 60 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( J, K ) G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) 60 CONTINUE 70 CONTINUE ELSE IF( TRANA.AND.TRANB )THEN DO 90 K = 1, KK DO 80 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( J, K ) G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) 80 CONTINUE 90 CONTINUE END IF DO 100 I = 1, M CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) 100 CONTINUE * * Compute the error ratio for this result. * ERR = ZERO DO 110 I = 1, M ERRI = ABS( CT( I ) - CC( I, J ) )/EPS IF( G( I ).NE.ZERO ) $ ERRI = ERRI/G( I ) ERR = MAX( ERR, ERRI ) IF( ERR*SQRT( EPS ).GE.ONE ) $ GO TO 130 110 CONTINUE * 120 CONTINUE * * If the loop completes, all results are at least half accurate. GO TO 150 * * Report fatal error. * 130 FATAL = .TRUE. WRITE( NOUT, FMT = 9999 ) DO 140 I = 1, M IF( MV )THEN WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) ELSE WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) END IF 140 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9997 )J * 150 CONTINUE RETURN * 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', $ 'TED RESULT' ) 9998 FORMAT( 1X, I7, 2G18.6 ) 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) * * End of DMMCH. * END LOGICAL FUNCTION LDE( RI, RJ, LR ) * * Tests if two arrays are identical. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER LR * .. Array Arguments .. DOUBLE PRECISION RI( * ), RJ( * ) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 10 I = 1, LR IF( RI( I ).NE.RJ( I ) ) $ GO TO 20 10 CONTINUE LDE = .TRUE. GO TO 30 20 CONTINUE LDE = .FALSE. 30 RETURN * * End of LDE. * END LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA ) * * Tests if selected elements in two arrays are equal. * * TYPE is 'GE' or 'SY'. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER LDA, M, N CHARACTER*1 UPLO CHARACTER*2 TYPE * .. Array Arguments .. DOUBLE PRECISION AA( LDA, * ), AS( LDA, * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J LOGICAL UPPER * .. Executable Statements .. UPPER = UPLO.EQ.'U' IF( TYPE.EQ.'GE' )THEN DO 20 J = 1, N DO 10 I = M + 1, LDA IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 10 CONTINUE 20 CONTINUE ELSE IF( TYPE.EQ.'SY' )THEN DO 50 J = 1, N IF( UPPER )THEN IBEG = 1 IEND = J ELSE IBEG = J IEND = N END IF DO 30 I = 1, IBEG - 1 IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 30 CONTINUE DO 40 I = IEND + 1, LDA IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 40 CONTINUE 50 CONTINUE END IF * 60 CONTINUE LDERES = .TRUE. GO TO 80 70 CONTINUE LDERES = .FALSE. 80 RETURN * * End of LDERES. * END DOUBLE PRECISION FUNCTION DBEG( RESET ) * * Generates random numbers uniformly distributed between -0.5 and 0.5. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. LOGICAL RESET * .. Local Scalars .. INTEGER I, IC, MI * .. Save statement .. SAVE I, IC, MI * .. Executable Statements .. IF( RESET )THEN * Initialize local variables. MI = 891 I = 7 IC = 0 RESET = .FALSE. END IF * * The sequence of values of I is bounded between 1 and 999. * If initial I = 1,2,3,6,7 or 9, the period will be 50. * If initial I = 4 or 8, the period will be 25. * If initial I = 5, the period will be 10. * IC is used to break up the period by skipping 1 value of I in 6. * IC = IC + 1 10 I = I*MI I = I - 1000*( I/1000 ) IF( IC.GE.5 )THEN IC = 0 GO TO 10 END IF DBEG = ( I - 500 )/1001.0D0 RETURN * * End of DBEG. * END DOUBLE PRECISION FUNCTION DDIFF( X, Y ) * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. DOUBLE PRECISION X, Y * .. Executable Statements .. DDIFF = X - Y RETURN * * End of DDIFF. * END SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * * Tests whether XERBLA has detected an error when it should. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT OK = .FALSE. END IF LERR = .FALSE. RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', $ 'ETECTED BY ', A6, ' *****' ) * * End of CHKXER. * END SUBROUTINE XERBLA( SRNAME, INFO ) * * This is a special version of XERBLA to be used only as part of * the test program for testing error exits from the Level 3 BLAS * routines. * * XERBLA is an error handler for the Level 3 BLAS routines. * * It is called by the Level 3 BLAS routines if an input parameter is * invalid. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER INFO CHARACTER*6 SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT * .. Executable Statements .. LERR = .TRUE. IF( INFO.NE.INFOT )THEN IF( INFOT.NE.0 )THEN WRITE( NOUT, FMT = 9999 )INFO, INFOT ELSE WRITE( NOUT, FMT = 9997 )INFO END IF OK = .FALSE. END IF IF( SRNAME.NE.SRNAMT )THEN WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT OK = .FALSE. END IF RETURN * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', $ 'AD OF ', A6, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check if test -f 'sblat3.f' then echo shar: will not over-write existing file "'sblat3.f'" else cat << SHAR_EOF > 'sblat3.f' PROGRAM SBLAT3 * * Test program for the REAL Level 3 Blas. * * The program must be driven by a short data file. The first 14 records * of the file are read using list-directed input, the last 6 records * are read using the format ( A6, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the * following 20 lines: * 'SBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE * 6 UNIT NUMBER OF SUMMARY FILE * 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. * F LOGICAL FLAG, T TO STOP ON FAILURES. * T LOGICAL FLAG, T TO TEST ERROR EXITS. * 16.0 THRESHOLD VALUE OF TEST RATIO * 6 NUMBER OF VALUES OF N * 0 1 2 3 5 9 VALUES OF N * 3 NUMBER OF VALUES OF ALPHA * 0.0 1.0 0.7 VALUES OF ALPHA * 3 NUMBER OF VALUES OF BETA * 0.0 1.0 1.3 VALUES OF BETA * SGEMM T PUT F FOR NO TEST. SAME COLUMNS. * SSYMM T PUT F FOR NO TEST. SAME COLUMNS. * STRMM T PUT F FOR NO TEST. SAME COLUMNS. * STRSM T PUT F FOR NO TEST. SAME COLUMNS. * SSYRK T PUT F FOR NO TEST. SAME COLUMNS. * SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. * * See: * * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. * A Set of Level 3 Basic Linear Algebra Subprograms. * * Technical Memorandum No.88 (Revision 1), Mathematics and * Computer Science Division, Argonne National Laboratory, 9700 * South Cass Avenue, Argonne, Illinois 60439, US. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS PARAMETER ( NSUBS = 6 ) REAL ZERO, HALF, ONE PARAMETER ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 ) INTEGER NMAX PARAMETER ( NMAX = 248 ) INTEGER NIDMAX, NALMAX, NBEMAX * PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) PARAMETER ( NIDMAX = 20, NALMAX = 7, NBEMAX = 7 ) * .. Local Scalars .. REAL EPS, ERR, THRESH INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB CHARACTER*6 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. REAL AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), $ ALF( NALMAX ), AS( NMAX*NMAX ), $ BB( NMAX*NMAX ), BET( NBEMAX ), $ BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) CHARACTER*6 SNAMES( NSUBS ) * .. External Functions .. REAL SDIFF LOGICAL LSE EXTERNAL SDIFF, LSE * .. External Subroutines .. EXTERNAL SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHKE, SMMCH * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ', $ 'SSYRK ', 'SSYR2K'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT * OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. * READ( NIN, FMT = * )SNAPS READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI REWI = REWI.AND.TRACE * Read the flag that directs stopping on any failure. READ( NIN, FMT = * )SFATAL * Read the flag that indicates whether error exits are to be tested. READ( NIN, FMT = * )TSTERR * Read the threshold value of the test ratio READ( NIN, FMT = * )THRESH * * Read and check the parameter values for the tests. * * Values of N READ( NIN, FMT = * )NIDIM IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN WRITE( NOUT, FMT = 9997 )'N', NIDMAX GO TO 220 END IF READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) DO 10 I = 1, NIDIM IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN WRITE( NOUT, FMT = 9996 )NMAX GO TO 220 END IF 10 CONTINUE * Values of ALPHA READ( NIN, FMT = * )NALF IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX GO TO 220 END IF READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) * Values of BETA READ( NIN, FMT = * )NBET IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX GO TO 220 END IF READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) * * Report values of parameters. * WRITE( NOUT, FMT = 9995 ) WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) IF( .NOT.TSTERR )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9984 ) END IF WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9999 )THRESH WRITE( NOUT, FMT = * ) * * Read names of subroutines and flags which indicate * whether they are to be tested. * DO 20 I = 1, NSUBS LTEST( I ) = .FALSE. 20 CONTINUE 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT DO 40 I = 1, NSUBS IF( SNAMET.EQ.SNAMES( I ) ) $ GO TO 50 40 CONTINUE WRITE( NOUT, FMT = 9990 )SNAMET STOP 50 LTEST( I ) = LTESTT GO TO 30 * 60 CONTINUE CLOSE ( NIN ) * * Compute EPS (the machine precision). * EPS = ONE 70 CONTINUE IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO ) $ GO TO 80 EPS = HALF*EPS GO TO 70 80 CONTINUE EPS = EPS + EPS WRITE( NOUT, FMT = 9998 )EPS * * Check the reliability of SMMCH using exact data. * N = MIN( 32, NMAX ) DO 100 J = 1, N DO 90 I = 1, N AB( I, J ) = MAX( I - J + 1, 0 ) 90 CONTINUE AB( J, NMAX + 1 ) = J AB( 1, NMAX + J ) = J C( J, 1 ) = ZERO 100 CONTINUE DO 110 J = 1, N CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 110 CONTINUE * CC holds the exact result. On exit from SMMCH CT holds * the result computed by SMMCH. TRANSA = 'N' TRANSB = 'N' CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LSE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF TRANSB = 'T' CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LSE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF DO 120 J = 1, N AB( J, NMAX + 1 ) = N - J + 1 AB( 1, NMAX + J ) = N - J + 1 120 CONTINUE DO 130 J = 1, N CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - $ ( ( J + 1 )*J*( J - 1 ) )/3 130 CONTINUE TRANSA = 'T' TRANSB = 'N' CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LSE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF TRANSB = 'T' CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LSE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF * * Test each subroutine in turn. * DO 200 ISNUM = 1, NSUBS WRITE( NOUT, FMT = * ) IF( .NOT.LTEST( ISNUM ) )THEN * Subprogram is not to be tested. WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) ELSE SRNAMT = SNAMES( ISNUM ) * Test error exits. IF( TSTERR )THEN CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) WRITE( NOUT, FMT = * ) END IF * Test computations. INFOT = 0 OK = .TRUE. FATAL = .FALSE. GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM * Test SGEMM, 01. 140 CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test SSYMM, 02. 150 CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test STRMM, 03, STRSM, 04. 160 CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) GO TO 190 * Test SSYRK, 05. 170 CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test SSYR2K, 06. 180 CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 END IF 200 CONTINUE WRITE( NOUT, FMT = 9986 ) GO TO 230 * 210 CONTINUE WRITE( NOUT, FMT = 9985 ) GO TO 230 * 220 CONTINUE WRITE( NOUT, FMT = 9991 ) * 230 CONTINUE IF( TRACE ) $ CLOSE ( NTRA ) CLOSE ( NOUT ) STOP * 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', $ 'S THAN', F8.2 ) 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 ) 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', $ 'THAN ', I2 ) 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) 9995 FORMAT( ' TESTS OF THE REAL LEVEL 3 BLAS', //' THE F', $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 9994 FORMAT( ' FOR N ', 9I6 ) 9993 FORMAT( ' FOR ALPHA ', 7F6.1 ) 9992 FORMAT( ' FOR BETA ', 7F6.1 ) 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', $ /' ******* TESTS ABANDONED *******' ) 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9989 FORMAT( ' ERROR IN SMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1, $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) 9988 FORMAT( A6, L2 ) 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) * * End of SBLAT3. * END SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests SGEMM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, $ MA, MB, MS, N, NA, NARGS, NB, NC, NS LOGICAL NULL, RESET, SAME, TRANA, TRANB CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB CHARACTER*3 ICH * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. EXTERNAL SGEMM, SMAKE, SMMCH * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICH/'NTC'/ * .. Executable Statements .. * NARGS = 13 NC = 0 RESET = .TRUE. ERRMAX = ZERO * DO 110 IM = 1, NIDIM M = IDIM( IM ) * DO 100 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = M IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N NULL = N.LE.0.OR.M.LE.0 * DO 90 IK = 1, NIDIM K = IDIM( IK ) * DO 80 ICA = 1, 3 TRANSA = ICH( ICA: ICA ) TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' * IF( TRANA )THEN MA = K NA = M ELSE MA = M NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * * Generate the matrix A. * CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 70 ICB = 1, 3 TRANSB = ICH( ICB: ICB ) TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' * IF( TRANB )THEN MB = N NB = K ELSE MB = K NB = N END IF * Set LDB to 1 more than minimum value if room. LDB = MB IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 70 LBB = LDB*NB * * Generate the matrix B. * CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, $ LDB, RESET, ZERO ) * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, $ CC, LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * TRANAS = TRANSA TRANBS = TRANSB MS = M NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, $ BETA, LDC IF( REWI ) $ REWIND NTRA CALL SGEMM( TRANSA, TRANSB, M, N, K, ALPHA, $ AA, LDA, BB, LDB, BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 120 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = TRANSA.EQ.TRANAS ISAME( 2 ) = TRANSB.EQ.TRANBS ISAME( 3 ) = MS.EQ.M ISAME( 4 ) = NS.EQ.N ISAME( 5 ) = KS.EQ.K ISAME( 6 ) = ALS.EQ.ALPHA ISAME( 7 ) = LSE( AS, AA, LAA ) ISAME( 8 ) = LDAS.EQ.LDA ISAME( 9 ) = LSE( BS, BB, LBB ) ISAME( 10 ) = LDBS.EQ.LDB ISAME( 11 ) = BLS.EQ.BETA IF( NULL )THEN ISAME( 12 ) = LSE( CS, CC, LCC ) ELSE ISAME( 12 ) = LSERES( 'GE', ' ', M, N, CS, $ CC, LDC ) END IF ISAME( 13 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report * and return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF * IF( .NOT.NULL )THEN * * Check the result. * CALL SMMCH( TRANSA, TRANSB, M, N, K, $ ALPHA, A, NMAX, B, NMAX, BETA, $ C, NMAX, CT, G, CC, LDC, EPS, $ ERR, FATAL, NOUT, .TRUE. ) ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 120 END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 130 * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, $ ALPHA, LDA, LDB, BETA, LDC * 130 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ', $ 'C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of SCHK1. * END SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests SSYMM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. REAL ALPHA, ALS, BETA, BLS, ERR, ERRMAX INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, $ NARGS, NC, NS LOGICAL LEFT, NULL, RESET, SAME CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. EXTERNAL SMAKE, SMMCH, SSYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. * NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = ZERO * DO 100 IM = 1, NIDIM M = IDIM( IM ) * DO 90 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = M IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 90 LCC = LDC*N NULL = N.LE.0.OR.M.LE.0 * * Set LDB to 1 more than minimum value if room. LDB = M IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 90 LBB = LDB*N * * Generate the matrix B. * CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, $ ZERO ) * DO 80 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE.EQ.'L' * IF( LEFT )THEN NA = M ELSE NA = N END IF * Set LDA to 1 more than minimum value if room. LDA = NA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) * * Generate the symmetric matrix A. * CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, $ LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * SIDES = SIDE UPLOS = UPLO MS = M NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, $ BB, LDB, BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 110 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = SIDES.EQ.SIDE ISAME( 2 ) = UPLOS.EQ.UPLO ISAME( 3 ) = MS.EQ.M ISAME( 4 ) = NS.EQ.N ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LSE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = LSE( BS, BB, LBB ) ISAME( 9 ) = LDBS.EQ.LDB ISAME( 10 ) = BLS.EQ.BETA IF( NULL )THEN ISAME( 11 ) = LSE( CS, CC, LCC ) ELSE ISAME( 11 ) = LSERES( 'GE', ' ', M, N, CS, $ CC, LDC ) END IF ISAME( 12 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 110 END IF * IF( .NOT.NULL )THEN * * Check the result. * IF( LEFT )THEN CALL SMMCH( 'N', 'N', M, N, M, ALPHA, A, $ NMAX, B, NMAX, BETA, C, NMAX, $ CT, G, CC, LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL SMMCH( 'N', 'N', M, N, N, ALPHA, B, $ NMAX, A, NMAX, BETA, C, NMAX, $ CT, G, CC, LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 110 END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 120 * 110 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, $ LDB, BETA, LDC * 120 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of SCHK2. * END SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, $ B, BB, BS, CT, G, C ) * * Tests STRMM and STRSM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. REAL ALPHA, ALS, ERR, ERRMAX INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, $ NS LOGICAL LEFT, NULL, RESET, SAME CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, $ UPLOS CHARACTER*2 ICHD, ICHS, ICHU CHARACTER*3 ICHT * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. EXTERNAL SMAKE, SMMCH, STRMM, STRSM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ * .. Executable Statements .. * NARGS = 11 NC = 0 RESET = .TRUE. ERRMAX = ZERO * Set up zero matrix for SMMCH. DO 20 J = 1, NMAX DO 10 I = 1, NMAX C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * DO 140 IM = 1, NIDIM M = IDIM( IM ) * DO 130 IN = 1, NIDIM N = IDIM( IN ) * Set LDB to 1 more than minimum value if room. LDB = M IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 130 LBB = LDB*N NULL = M.LE.0.OR.N.LE.0 * DO 120 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE.EQ.'L' IF( LEFT )THEN NA = M ELSE NA = N END IF * Set LDA to 1 more than minimum value if room. LDA = NA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 130 LAA = LDA*NA * DO 110 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) * DO 100 ICT = 1, 3 TRANSA = ICHT( ICT: ICT ) * DO 90 ICD = 1, 2 DIAG = ICHD( ICD: ICD ) * DO 80 IA = 1, NALF ALPHA = ALF( IA ) * * Generate the matrix A. * CALL SMAKE( 'TR', UPLO, DIAG, NA, NA, A, $ NMAX, AA, LDA, RESET, ZERO ) * * Generate the matrix B. * CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, $ BB, LDB, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * SIDES = SIDE UPLOS = UPLO TRANAS = TRANSA DIAGS = DIAG MS = M NS = N ALS = ALPHA DO 30 I = 1, LAA AS( I ) = AA( I ) 30 CONTINUE LDAS = LDA DO 40 I = 1, LBB BS( I ) = BB( I ) 40 CONTINUE LDBS = LDB * * Call the subroutine. * IF( SNAME( 4: 5 ).EQ.'MM' )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, $ LDA, LDB IF( REWI ) $ REWIND NTRA CALL STRMM( SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, AA, LDA, BB, LDB ) ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, $ LDA, LDB IF( REWI ) $ REWIND NTRA CALL STRSM( SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, AA, LDA, BB, LDB ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 150 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = SIDES.EQ.SIDE ISAME( 2 ) = UPLOS.EQ.UPLO ISAME( 3 ) = TRANAS.EQ.TRANSA ISAME( 4 ) = DIAGS.EQ.DIAG ISAME( 5 ) = MS.EQ.M ISAME( 6 ) = NS.EQ.N ISAME( 7 ) = ALS.EQ.ALPHA ISAME( 8 ) = LSE( AS, AA, LAA ) ISAME( 9 ) = LDAS.EQ.LDA IF( NULL )THEN ISAME( 10 ) = LSE( BS, BB, LBB ) ELSE ISAME( 10 ) = LSERES( 'GE', ' ', M, N, BS, $ BB, LDB ) END IF ISAME( 11 ) = LDBS.EQ.LDB * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 50 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 50 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 150 END IF * IF( .NOT.NULL )THEN IF( SNAME( 4: 5 ).EQ.'MM' )THEN * * Check the result. * IF( LEFT )THEN CALL SMMCH( TRANSA, 'N', M, N, M, $ ALPHA, A, NMAX, B, NMAX, $ ZERO, C, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL SMMCH( 'N', TRANSA, M, N, N, $ ALPHA, B, NMAX, A, NMAX, $ ZERO, C, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN * * Compute approximation to original * matrix. * DO 70 J = 1, N DO 60 I = 1, M C( I, J ) = BB( I + ( J - 1 )* $ LDB ) BB( I + ( J - 1 )*LDB ) = ALPHA* $ B( I, J ) 60 CONTINUE 70 CONTINUE * IF( LEFT )THEN CALL SMMCH( TRANSA, 'N', M, N, M, $ ONE, A, NMAX, C, NMAX, $ ZERO, B, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .FALSE. ) ELSE CALL SMMCH( 'N', TRANSA, M, N, N, $ ONE, C, NMAX, A, NMAX, $ ZERO, B, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .FALSE. ) END IF END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 150 END IF * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * 120 CONTINUE * 130 CONTINUE * 140 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 160 * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, LDA, LDB * 160 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of SCHK3. * END SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests SSYRK. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. REAL A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, $ NARGS, NC, NS LOGICAL NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. EXTERNAL SMAKE, SMMCH, SSYRK * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * NARGS = 10 NC = 0 RESET = .TRUE. ERRMAX = ZERO * DO 100 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N NULL = N.LE.0 * DO 90 IK = 1, NIDIM K = IDIM( IK ) * DO 80 ICT = 1, 3 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * * Generate the matrix A. * CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U' * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, $ LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the subroutine. * UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA BETS = BETA DO 20 I = 1, LCC CS( I ) = CC( I ) 20 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, BETA, LDC IF( REWI ) $ REWIND NTRA CALL SSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA, $ BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9993 ) FATAL = .TRUE. GO TO 120 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LSE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = BETS.EQ.BETA IF( NULL )THEN ISAME( 9 ) = LSE( CS, CC, LCC ) ELSE ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS, $ CC, LDC ) END IF ISAME( 10 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 30 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 30 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF * IF( .NOT.NULL )THEN * * Check the result column by column. * JC = 1 DO 40 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA, $ A( 1, JJ ), NMAX, $ A( 1, J ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA, $ A( JJ, 1 ), NMAX, $ A( J, 1 ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 110 40 CONTINUE END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 130 * 110 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, BETA, LDC * 130 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of SCHK4. * END SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) * * Tests SSYR2K. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0 ) * .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS LOGICAL NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LSE, LSERES EXTERNAL LSE, LSERES * .. External Subroutines .. EXTERNAL SMAKE, SMMCH, SSYR2K * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHT/'NTC'/, ICHU/'UL'/ * .. Executable Statements .. * NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = ZERO * DO 130 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 130 LCC = LDC*N NULL = N.LE.0 * DO 120 IK = 1, NIDIM K = IDIM( IK ) * DO 110 ICT = 1, 3 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 110 LAA = LDA*NA * * Generate the matrix A. * IF( TRAN )THEN CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, $ LDA, RESET, ZERO ) ELSE CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, $ RESET, ZERO ) END IF * * Generate the matrix B. * LDB = LDA LBB = LAA IF( TRAN )THEN CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), $ 2*NMAX, BB, LDB, RESET, ZERO ) ELSE CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), $ NMAX, BB, LDB, RESET, ZERO ) END IF * DO 100 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U' * DO 90 IA = 1, NALF ALPHA = ALF( IA ) * DO 80 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, $ LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the subroutine. * UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BETS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA, $ BB, LDB, BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9993 ) FATAL = .TRUE. GO TO 150 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LSE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = LSE( BS, BB, LBB ) ISAME( 9 ) = LDBS.EQ.LDB ISAME( 10 ) = BETS.EQ.BETA IF( NULL )THEN ISAME( 11 ) = LSE( CS, CC, LCC ) ELSE ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS, $ CC, LDC ) END IF ISAME( 12 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 150 END IF * IF( .NOT.NULL )THEN * * Check the result column by column. * JJAB = 1 JC = 1 DO 70 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN DO 50 I = 1, K W( I ) = AB( ( J - 1 )*2*NMAX + K + $ I ) W( K + I ) = AB( ( J - 1 )*2*NMAX + $ I ) 50 CONTINUE CALL SMMCH( 'T', 'N', LJ, 1, 2*K, $ ALPHA, AB( JJAB ), 2*NMAX, $ W, 2*NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE DO 60 I = 1, K W( I ) = AB( ( K + I - 1 )*NMAX + $ J ) W( K + I ) = AB( ( I - 1 )*NMAX + $ J ) 60 CONTINUE CALL SMMCH( 'N', 'N', LJ, 1, 2*K, $ ALPHA, AB( JJ ), NMAX, W, $ 2*NMAX, BETA, C( JJ, J ), $ NMAX, CT, G, CC( JC ), LDC, $ EPS, ERR, FATAL, NOUT, $ .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 IF( TRAN ) $ JJAB = JJAB + 2*NMAX END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 140 70 CONTINUE END IF * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * 120 CONTINUE * 130 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 160 * 140 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, LDB, BETA, LDC * 160 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of SCHK5. * END SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT ) * * Tests the error exits from the Level 3 Blas. * Requires a special version of the error-handling routine XERBLA. * ALPHA, BETA, A, B and C should not need to be defined. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER ISNUM, NOUT CHARACTER*6 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Local Scalars .. REAL ALPHA, BETA * .. Local Arrays .. REAL A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) * .. External Subroutines .. EXTERNAL CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM, $ STRSM * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Executable Statements .. * OK is set to .FALSE. by the special version of XERBLA or by CHKXER * if anything is wrong. OK = .TRUE. * LERR is set to .TRUE. by the special version of XERBLA each time * it is called, and is then tested and re-set by CHKXER. LERR = .FALSE. GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM 10 INFOT = 1 CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 CALL SGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL SGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL SGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL SGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL SGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL SGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL SGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 20 INFOT = 1 CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 30 INFOT = 1 CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL STRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL STRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL STRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 40 INFOT = 1 CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL STRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL STRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL STRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL STRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL STRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL STRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 50 INFOT = 1 CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 70 60 INFOT = 1 CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL SSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL SSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL SSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * 70 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT END IF RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of SCHKE. * END SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, $ TRANSL ) * * Generates values for an M by N matrix A. * Stores the values in the array AA in the data structure required * by the routine, with unwanted elements set to rogue value. * * TYPE is 'GE', 'SY' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) REAL ROGUE PARAMETER ( ROGUE = -1.0E10 ) * .. Scalar Arguments .. REAL TRANSL INTEGER LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO CHARACTER*2 TYPE * .. Array Arguments .. REAL A( NMAX, * ), AA( * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER * .. External Functions .. REAL SBEG EXTERNAL SBEG * .. Executable Statements .. GEN = TYPE.EQ.'GE' SYM = TYPE.EQ.'SY' TRI = TYPE.EQ.'TR' UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U' LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. * DO 20 J = 1, N DO 10 I = 1, M IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) $ THEN A( I, J ) = SBEG( RESET ) + TRANSL IF( I.NE.J )THEN * Set some elements to zero IF( N.GT.3.AND.J.EQ.N/2 ) $ A( I, J ) = ZERO IF( SYM )THEN A( J, I ) = A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF END IF END IF 10 CONTINUE IF( TRI ) $ A( J, J ) = A( J, J ) + ONE IF( UNIT ) $ A( J, J ) = ONE 20 CONTINUE * * Store elements in array AS in data structure required by routine. * IF( TYPE.EQ.'GE' )THEN DO 50 J = 1, N DO 30 I = 1, M AA( I + ( J - 1 )*LDA ) = A( I, J ) 30 CONTINUE DO 40 I = M + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 40 CONTINUE 50 CONTINUE ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 IF( UNIT )THEN IEND = J - 1 ELSE IEND = J END IF ELSE IF( UNIT )THEN IBEG = J + 1 ELSE IBEG = J END IF IEND = N END IF DO 60 I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE 60 CONTINUE DO 70 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I, J ) 70 CONTINUE DO 80 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 80 CONTINUE 90 CONTINUE END IF RETURN * * End of SMAKE. * END SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, $ NOUT, MV ) * * Checks the results of the computational tests. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. REAL ZERO, ONE PARAMETER ( ZERO = 0.0, ONE = 1.0 ) * .. Scalar Arguments .. REAL ALPHA, BETA, EPS, ERR INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT LOGICAL FATAL, MV CHARACTER*1 TRANSA, TRANSB * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ), $ CC( LDCC, * ), CT( * ), G( * ) * .. Local Scalars .. REAL ERRI INTEGER I, J, K LOGICAL TRANA, TRANB * .. Intrinsic Functions .. INTRINSIC ABS, MAX, SQRT * .. Executable Statements .. TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' * * Compute expected result, one column at a time, in CT using data * in A, B and C. * Compute gauges in G. * DO 120 J = 1, N * DO 10 I = 1, M CT( I ) = ZERO G( I ) = ZERO 10 CONTINUE IF( .NOT.TRANA.AND..NOT.TRANB )THEN DO 30 K = 1, KK DO 20 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( K, J ) G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) ) 20 CONTINUE 30 CONTINUE ELSE IF( TRANA.AND..NOT.TRANB )THEN DO 50 K = 1, KK DO 40 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( K, J ) G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) ) 40 CONTINUE 50 CONTINUE ELSE IF( .NOT.TRANA.AND.TRANB )THEN DO 70 K = 1, KK DO 60 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( J, K ) G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) ) 60 CONTINUE 70 CONTINUE ELSE IF( TRANA.AND.TRANB )THEN DO 90 K = 1, KK DO 80 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( J, K ) G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) ) 80 CONTINUE 90 CONTINUE END IF DO 100 I = 1, M CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) ) 100 CONTINUE * * Compute the error ratio for this result. * ERR = ZERO DO 110 I = 1, M ERRI = ABS( CT( I ) - CC( I, J ) )/EPS IF( G( I ).NE.ZERO ) $ ERRI = ERRI/G( I ) ERR = MAX( ERR, ERRI ) IF( ERR*SQRT( EPS ).GE.ONE ) $ GO TO 130 110 CONTINUE * 120 CONTINUE * * If the loop completes, all results are at least half accurate. GO TO 150 * * Report fatal error. * 130 FATAL = .TRUE. WRITE( NOUT, FMT = 9999 ) DO 140 I = 1, M IF( MV )THEN WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) ELSE WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) END IF 140 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9997 )J * 150 CONTINUE RETURN * 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU', $ 'TED RESULT' ) 9998 FORMAT( 1X, I7, 2G18.6 ) 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) * * End of SMMCH. * END LOGICAL FUNCTION LSE( RI, RJ, LR ) * * Tests if two arrays are identical. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER LR * .. Array Arguments .. REAL RI( * ), RJ( * ) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 10 I = 1, LR IF( RI( I ).NE.RJ( I ) ) $ GO TO 20 10 CONTINUE LSE = .TRUE. GO TO 30 20 CONTINUE LSE = .FALSE. 30 RETURN * * End of LSE. * END LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA ) * * Tests if selected elements in two arrays are equal. * * TYPE is 'GE' or 'SY'. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER LDA, M, N CHARACTER*1 UPLO CHARACTER*2 TYPE * .. Array Arguments .. REAL AA( LDA, * ), AS( LDA, * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J LOGICAL UPPER * .. Executable Statements .. UPPER = UPLO.EQ.'U' IF( TYPE.EQ.'GE' )THEN DO 20 J = 1, N DO 10 I = M + 1, LDA IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 10 CONTINUE 20 CONTINUE ELSE IF( TYPE.EQ.'SY' )THEN DO 50 J = 1, N IF( UPPER )THEN IBEG = 1 IEND = J ELSE IBEG = J IEND = N END IF DO 30 I = 1, IBEG - 1 IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 30 CONTINUE DO 40 I = IEND + 1, LDA IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 40 CONTINUE 50 CONTINUE END IF * 60 CONTINUE LSERES = .TRUE. GO TO 80 70 CONTINUE LSERES = .FALSE. 80 RETURN * * End of LSERES. * END REAL FUNCTION SBEG( RESET ) * * Generates random numbers uniformly distributed between -0.5 and 0.5. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. LOGICAL RESET * .. Local Scalars .. INTEGER I, IC, MI * .. Save statement .. SAVE I, IC, MI * .. Executable Statements .. IF( RESET )THEN * Initialize local variables. MI = 891 I = 7 IC = 0 RESET = .FALSE. END IF * * The sequence of values of I is bounded between 1 and 999. * If initial I = 1,2,3,6,7 or 9, the period will be 50. * If initial I = 4 or 8, the period will be 25. * If initial I = 5, the period will be 10. * IC is used to break up the period by skipping 1 value of I in 6. * IC = IC + 1 10 I = I*MI I = I - 1000*( I/1000 ) IF( IC.GE.5 )THEN IC = 0 GO TO 10 END IF SBEG = ( I - 500 )/1001.0 RETURN * * End of SBEG. * END REAL FUNCTION SDIFF( X, Y ) * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. REAL X, Y * .. Executable Statements .. SDIFF = X - Y RETURN * * End of SDIFF. * END SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * * Tests whether XERBLA has detected an error when it should. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT OK = .FALSE. END IF LERR = .FALSE. RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', $ 'ETECTED BY ', A6, ' *****' ) * * End of CHKXER. * END SUBROUTINE XERBLA( SRNAME, INFO ) * * This is a special version of XERBLA to be used only as part of * the test program for testing error exits from the Level 3 BLAS * routines. * * XERBLA is an error handler for the Level 3 BLAS routines. * * It is called by the Level 3 BLAS routines if an input parameter is * invalid. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER INFO CHARACTER*6 SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT * .. Executable Statements .. LERR = .TRUE. IF( INFO.NE.INFOT )THEN IF( INFOT.NE.0 )THEN WRITE( NOUT, FMT = 9999 )INFO, INFOT ELSE WRITE( NOUT, FMT = 9997 )INFO END IF OK = .FALSE. END IF IF( SRNAME.NE.SRNAMT )THEN WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT OK = .FALSE. END IF RETURN * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', $ 'AD OF ', A6, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check if test -f 'zblat3.f' then echo shar: will not over-write existing file "'zblat3.f'" else cat << SHAR_EOF > 'zblat3.f' PROGRAM ZBLAT3 * * Test program for the COMPLEX*16 Level 3 Blas. * * The program must be driven by a short data file. The first 14 records * of the file are read using list-directed input, the last 9 records * are read using the format ( A6, L2 ). An annotated example of a data * file can be obtained by deleting the first 3 characters from the * following 23 lines: * 'ZBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE * 6 UNIT NUMBER OF SUMMARY FILE * 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE * -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) * F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. * F LOGICAL FLAG, T TO STOP ON FAILURES. * T LOGICAL FLAG, T TO TEST ERROR EXITS. * 16.0 THRESHOLD VALUE OF TEST RATIO * 6 NUMBER OF VALUES OF N * 0 1 2 3 5 9 VALUES OF N * 3 NUMBER OF VALUES OF ALPHA * (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA * 3 NUMBER OF VALUES OF BETA * (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA * ZGEMM T PUT F FOR NO TEST. SAME COLUMNS. * ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. * ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. * ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. * ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. * ZHERK T PUT F FOR NO TEST. SAME COLUMNS. * ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. * ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. * ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. * * See: * * Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S. * A Set of Level 3 Basic Linear Algebra Subprograms. * * Technical Memorandum No.88 (Revision 1), Mathematics and * Computer Science Division, Argonne National Laboratory, 9700 * South Cass Avenue, Argonne, Illinois 60439, US. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. INTEGER NIN PARAMETER ( NIN = 5 ) INTEGER NSUBS PARAMETER ( NSUBS = 9 ) COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO, RHALF, RONE PARAMETER ( RZERO = 0.0D0, RHALF = 0.5D0, RONE = 1.0D0 ) INTEGER NMAX PARAMETER ( NMAX = 176 ) INTEGER NIDMAX, NALMAX, NBEMAX * PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 ) PARAMETER ( NIDMAX = 20, NALMAX = 7, NBEMAX = 7 ) * .. Local Scalars .. DOUBLE PRECISION EPS, ERR, THRESH INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE, $ TSTERR CHARACTER*1 TRANSA, TRANSB CHARACTER*6 SNAMET CHARACTER*32 SNAPS, SUMMRY * .. Local Arrays .. COMPLEX*16 AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ), $ ALF( NALMAX ), AS( NMAX*NMAX ), $ BB( NMAX*NMAX ), BET( NBEMAX ), $ BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ W( 2*NMAX ) DOUBLE PRECISION G( NMAX ) INTEGER IDIM( NIDMAX ) LOGICAL LTEST( NSUBS ) CHARACTER*6 SNAMES( NSUBS ) * .. External Functions .. DOUBLE PRECISION DDIFF LOGICAL LZE EXTERNAL DDIFF, LZE * .. External Subroutines .. EXTERNAL ZCHK1, ZCHK2, ZCHK3, ZCHK4, ZCHK5, ZCHKE, ZMMCH * .. Intrinsic Functions .. INTRINSIC MAX, MIN * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR COMMON /SRNAMC/SRNAMT * .. Data statements .. DATA SNAMES/'ZGEMM ', 'ZHEMM ', 'ZSYMM ', 'ZTRMM ', $ 'ZTRSM ', 'ZHERK ', 'ZSYRK ', 'ZHER2K', $ 'ZSYR2K'/ * .. Executable Statements .. * * Read name and unit number for summary output file and open file. * READ( NIN, FMT = * )SUMMRY READ( NIN, FMT = * )NOUT * OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' ) OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' ) NOUTC = NOUT * * Read name and unit number for snapshot output file and open file. * READ( NIN, FMT = * )SNAPS READ( NIN, FMT = * )NTRA TRACE = NTRA.GE.0 IF( TRACE )THEN OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' ) END IF * Read the flag that directs rewinding of the snapshot file. READ( NIN, FMT = * )REWI REWI = REWI.AND.TRACE * Read the flag that directs stopping on any failure. READ( NIN, FMT = * )SFATAL * Read the flag that indicates whether error exits are to be tested. READ( NIN, FMT = * )TSTERR * Read the threshold value of the test ratio READ( NIN, FMT = * )THRESH * * Read and check the parameter values for the tests. * * Values of N READ( NIN, FMT = * )NIDIM IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN WRITE( NOUT, FMT = 9997 )'N', NIDMAX GO TO 220 END IF READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM ) DO 10 I = 1, NIDIM IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN WRITE( NOUT, FMT = 9996 )NMAX GO TO 220 END IF 10 CONTINUE * Values of ALPHA READ( NIN, FMT = * )NALF IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX GO TO 220 END IF READ( NIN, FMT = * )( ALF( I ), I = 1, NALF ) * Values of BETA READ( NIN, FMT = * )NBET IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX GO TO 220 END IF READ( NIN, FMT = * )( BET( I ), I = 1, NBET ) * * Report values of parameters. * WRITE( NOUT, FMT = 9995 ) WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM ) WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF ) WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET ) IF( .NOT.TSTERR )THEN WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9984 ) END IF WRITE( NOUT, FMT = * ) WRITE( NOUT, FMT = 9999 )THRESH WRITE( NOUT, FMT = * ) * * Read names of subroutines and flags which indicate * whether they are to be tested. * DO 20 I = 1, NSUBS LTEST( I ) = .FALSE. 20 CONTINUE 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT DO 40 I = 1, NSUBS IF( SNAMET.EQ.SNAMES( I ) ) $ GO TO 50 40 CONTINUE WRITE( NOUT, FMT = 9990 )SNAMET STOP 50 LTEST( I ) = LTESTT GO TO 30 * 60 CONTINUE CLOSE ( NIN ) * * Compute EPS (the machine precision). * EPS = RONE 70 CONTINUE IF( DDIFF( RONE + EPS, RONE ).EQ.RZERO ) $ GO TO 80 EPS = RHALF*EPS GO TO 70 80 CONTINUE EPS = EPS + EPS WRITE( NOUT, FMT = 9998 )EPS * * Check the reliability of ZMMCH using exact data. * N = MIN( 32, NMAX ) DO 100 J = 1, N DO 90 I = 1, N AB( I, J ) = MAX( I - J + 1, 0 ) 90 CONTINUE AB( J, NMAX + 1 ) = J AB( 1, NMAX + J ) = J C( J, 1 ) = ZERO 100 CONTINUE DO 110 J = 1, N CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3 110 CONTINUE * CC holds the exact result. On exit from ZMMCH CT holds * the result computed by ZMMCH. TRANSA = 'N' TRANSB = 'N' CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LZE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF TRANSB = 'C' CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LZE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF DO 120 J = 1, N AB( J, NMAX + 1 ) = N - J + 1 AB( 1, NMAX + J ) = N - J + 1 120 CONTINUE DO 130 J = 1, N CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 - $ ( ( J + 1 )*J*( J - 1 ) )/3 130 CONTINUE TRANSA = 'C' TRANSB = 'N' CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LZE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF TRANSB = 'C' CALL ZMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX, $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC, $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. ) SAME = LZE( CC, CT, N ) IF( .NOT.SAME.OR.ERR.NE.RZERO )THEN WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR STOP END IF * * Test each subroutine in turn. * DO 200 ISNUM = 1, NSUBS WRITE( NOUT, FMT = * ) IF( .NOT.LTEST( ISNUM ) )THEN * Subprogram is not to be tested. WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM ) ELSE SRNAMT = SNAMES( ISNUM ) * Test error exits. IF( TSTERR )THEN CALL ZCHKE( ISNUM, SNAMES( ISNUM ), NOUT ) WRITE( NOUT, FMT = * ) END IF * Test computations. INFOT = 0 OK = .TRUE. FATAL = .FALSE. GO TO ( 140, 150, 150, 160, 160, 170, 170, $ 180, 180 )ISNUM * Test ZGEMM, 01. 140 CALL ZCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test ZHEMM, 02, ZSYMM, 03. 150 CALL ZCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test ZTRMM, 04, ZTRSM, 05. 160 CALL ZCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB, $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C ) GO TO 190 * Test ZHERK, 06, ZSYRK, 07. 170 CALL ZCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C, $ CC, CS, CT, G ) GO TO 190 * Test ZHER2K, 08, ZSYR2K, 09. 180 CALL ZCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE, $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) GO TO 190 * 190 IF( FATAL.AND.SFATAL ) $ GO TO 210 END IF 200 CONTINUE WRITE( NOUT, FMT = 9986 ) GO TO 230 * 210 CONTINUE WRITE( NOUT, FMT = 9985 ) GO TO 230 * 220 CONTINUE WRITE( NOUT, FMT = 9991 ) * 230 CONTINUE IF( TRACE ) $ CLOSE ( NTRA ) CLOSE ( NOUT ) STOP * 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES', $ 'S THAN', F8.2 ) 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 ) 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ', $ 'THAN ', I2 ) 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 ) 9995 FORMAT( ' TESTS OF THE COMPLEX*16 LEVEL 3 BLAS', //' THE F', $ 'OLLOWING PARAMETER VALUES WILL BE USED:' ) 9994 FORMAT( ' FOR N ', 9I6 ) 9993 FORMAT( ' FOR ALPHA ', $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9992 FORMAT( ' FOR BETA ', $ 7( '(', F4.1, ',', F4.1, ') ', : ) ) 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM', $ /' ******* TESTS ABANDONED *******' ) 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T', $ 'ESTS ABANDONED *******' ) 9989 FORMAT( ' ERROR IN ZMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU', $ 'ATED WRONGLY.', /' ZMMCH WAS CALLED WITH TRANSA = ', A1, $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ', $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ', $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ', $ '*******' ) 9988 FORMAT( A6, L2 ) 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' ) 9986 FORMAT( /' END OF TESTS' ) 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' ) 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' ) * * End of ZBLAT3. * END SUBROUTINE ZCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests ZGEMM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ) DOUBLE PRECISION G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX*16 ALPHA, ALS, BETA, BLS DOUBLE PRECISION ERR, ERRMAX INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA, $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M, $ MA, MB, MS, N, NA, NARGS, NB, NC, NS LOGICAL NULL, RESET, SAME, TRANA, TRANB CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB CHARACTER*3 ICH * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LZE, LZERES EXTERNAL LZE, LZERES * .. External Subroutines .. EXTERNAL ZGEMM, ZMAKE, ZMMCH * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICH/'NTC'/ * .. Executable Statements .. * NARGS = 13 NC = 0 RESET = .TRUE. ERRMAX = RZERO * DO 110 IM = 1, NIDIM M = IDIM( IM ) * DO 100 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = M IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N NULL = N.LE.0.OR.M.LE.0 * DO 90 IK = 1, NIDIM K = IDIM( IK ) * DO 80 ICA = 1, 3 TRANSA = ICH( ICA: ICA ) TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' * IF( TRANA )THEN MA = K NA = M ELSE MA = M NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * * Generate the matrix A. * CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 70 ICB = 1, 3 TRANSB = ICH( ICB: ICB ) TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' * IF( TRANB )THEN MB = N NB = K ELSE MB = K NB = N END IF * Set LDB to 1 more than minimum value if room. LDB = MB IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 70 LBB = LDB*NB * * Generate the matrix B. * CALL ZMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB, $ LDB, RESET, ZERO ) * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, $ CC, LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * TRANAS = TRANSA TRANBS = TRANSB MS = M NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB, $ BETA, LDC IF( REWI ) $ REWIND NTRA CALL ZGEMM( TRANSA, TRANSB, M, N, K, ALPHA, $ AA, LDA, BB, LDB, BETA, CC, LDC ) * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 120 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = TRANSA.EQ.TRANAS ISAME( 2 ) = TRANSB.EQ.TRANBS ISAME( 3 ) = MS.EQ.M ISAME( 4 ) = NS.EQ.N ISAME( 5 ) = KS.EQ.K ISAME( 6 ) = ALS.EQ.ALPHA ISAME( 7 ) = LZE( AS, AA, LAA ) ISAME( 8 ) = LDAS.EQ.LDA ISAME( 9 ) = LZE( BS, BB, LBB ) ISAME( 10 ) = LDBS.EQ.LDB ISAME( 11 ) = BLS.EQ.BETA IF( NULL )THEN ISAME( 12 ) = LZE( CS, CC, LCC ) ELSE ISAME( 12 ) = LZERES( 'GE', ' ', M, N, CS, $ CC, LDC ) END IF ISAME( 13 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report * and return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF * IF( .NOT.NULL )THEN * * Check the result. * CALL ZMMCH( TRANSA, TRANSB, M, N, K, $ ALPHA, A, NMAX, B, NMAX, BETA, $ C, NMAX, CT, G, CC, LDC, EPS, $ ERR, FATAL, NOUT, .TRUE. ) ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 120 END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 130 * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K, $ ALPHA, LDA, LDB, BETA, LDC * 130 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',', $ 3( I3, ',' ), '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, $ ',(', F4.1, ',', F4.1, '), C,', I3, ').' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of ZCHK1. * END SUBROUTINE ZCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests ZHEMM and ZSYMM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ) DOUBLE PRECISION G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX*16 ALPHA, ALS, BETA, BLS DOUBLE PRECISION ERR, ERRMAX INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC, $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA, $ NARGS, NC, NS LOGICAL CONJ, LEFT, NULL, RESET, SAME CHARACTER*1 SIDE, SIDES, UPLO, UPLOS CHARACTER*2 ICHS, ICHU * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LZE, LZERES EXTERNAL LZE, LZERES * .. External Subroutines .. EXTERNAL ZHEMM, ZMAKE, ZMMCH, ZSYMM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHS/'LR'/, ICHU/'UL'/ * .. Executable Statements .. CONJ = SNAME( 2: 3 ).EQ.'HE' * NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = RZERO * DO 100 IM = 1, NIDIM M = IDIM( IM ) * DO 90 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = M IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 90 LCC = LDC*N NULL = N.LE.0.OR.M.LE.0 * Set LDB to 1 more than minimum value if room. LDB = M IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 90 LBB = LDB*N * * Generate the matrix B. * CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET, $ ZERO ) * DO 80 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE.EQ.'L' * IF( LEFT )THEN NA = M ELSE NA = N END IF * Set LDA to 1 more than minimum value if room. LDA = NA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) * * Generate the hermitian or symmetric matrix A. * CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', NA, NA, A, NMAX, $ AA, LDA, RESET, ZERO ) * DO 60 IA = 1, NALF ALPHA = ALF( IA ) * DO 50 IB = 1, NBET BETA = BET( IB ) * * Generate the matrix C. * CALL ZMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC, $ LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * SIDES = SIDE UPLOS = UPLO MS = M NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB BLS = BETA DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE, $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA IF( CONJ )THEN CALL ZHEMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, $ BB, LDB, BETA, CC, LDC ) ELSE CALL ZSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA, $ BB, LDB, BETA, CC, LDC ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 110 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = SIDES.EQ.SIDE ISAME( 2 ) = UPLOS.EQ.UPLO ISAME( 3 ) = MS.EQ.M ISAME( 4 ) = NS.EQ.N ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LZE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = LZE( BS, BB, LBB ) ISAME( 9 ) = LDBS.EQ.LDB ISAME( 10 ) = BLS.EQ.BETA IF( NULL )THEN ISAME( 11 ) = LZE( CS, CC, LCC ) ELSE ISAME( 11 ) = LZERES( 'GE', ' ', M, N, CS, $ CC, LDC ) END IF ISAME( 12 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 110 END IF * IF( .NOT.NULL )THEN * * Check the result. * IF( LEFT )THEN CALL ZMMCH( 'N', 'N', M, N, M, ALPHA, A, $ NMAX, B, NMAX, BETA, C, NMAX, $ CT, G, CC, LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL ZMMCH( 'N', 'N', M, N, N, ALPHA, B, $ NMAX, A, NMAX, BETA, C, NMAX, $ CT, G, CC, LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 110 END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 120 * 110 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA, $ LDB, BETA, LDC * 120 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, $ ',', F4.1, '), C,', I3, ') .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of ZCHK2. * END SUBROUTINE ZCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS, $ B, BB, BS, CT, G, C ) * * Tests ZTRMM and ZTRSM. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CT( NMAX ) DOUBLE PRECISION G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX*16 ALPHA, ALS DOUBLE PRECISION ERR, ERRMAX INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB, $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC, $ NS LOGICAL LEFT, NULL, RESET, SAME CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO, $ UPLOS CHARACTER*2 ICHD, ICHS, ICHU CHARACTER*3 ICHT * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LZE, LZERES EXTERNAL LZE, LZERES * .. External Subroutines .. EXTERNAL ZMAKE, ZMMCH, ZTRMM, ZTRSM * .. Intrinsic Functions .. INTRINSIC MAX * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/ * .. Executable Statements .. * NARGS = 11 NC = 0 RESET = .TRUE. ERRMAX = RZERO * Set up zero matrix for ZMMCH. DO 20 J = 1, NMAX DO 10 I = 1, NMAX C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE * DO 140 IM = 1, NIDIM M = IDIM( IM ) * DO 130 IN = 1, NIDIM N = IDIM( IN ) * Set LDB to 1 more than minimum value if room. LDB = M IF( LDB.LT.NMAX ) $ LDB = LDB + 1 * Skip tests if not enough room. IF( LDB.GT.NMAX ) $ GO TO 130 LBB = LDB*N NULL = M.LE.0.OR.N.LE.0 * DO 120 ICS = 1, 2 SIDE = ICHS( ICS: ICS ) LEFT = SIDE.EQ.'L' IF( LEFT )THEN NA = M ELSE NA = N END IF * Set LDA to 1 more than minimum value if room. LDA = NA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 130 LAA = LDA*NA * DO 110 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) * DO 100 ICT = 1, 3 TRANSA = ICHT( ICT: ICT ) * DO 90 ICD = 1, 2 DIAG = ICHD( ICD: ICD ) * DO 80 IA = 1, NALF ALPHA = ALF( IA ) * * Generate the matrix A. * CALL ZMAKE( 'TR', UPLO, DIAG, NA, NA, A, $ NMAX, AA, LDA, RESET, ZERO ) * * Generate the matrix B. * CALL ZMAKE( 'GE', ' ', ' ', M, N, B, NMAX, $ BB, LDB, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the * subroutine. * SIDES = SIDE UPLOS = UPLO TRANAS = TRANSA DIAGS = DIAG MS = M NS = N ALS = ALPHA DO 30 I = 1, LAA AS( I ) = AA( I ) 30 CONTINUE LDAS = LDA DO 40 I = 1, LBB BS( I ) = BB( I ) 40 CONTINUE LDBS = LDB * * Call the subroutine. * IF( SNAME( 4: 5 ).EQ.'MM' )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, $ LDA, LDB IF( REWI ) $ REWIND NTRA CALL ZTRMM( SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, AA, LDA, BB, LDB ) ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA, $ LDA, LDB IF( REWI ) $ REWIND NTRA CALL ZTRSM( SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, AA, LDA, BB, LDB ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9994 ) FATAL = .TRUE. GO TO 150 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = SIDES.EQ.SIDE ISAME( 2 ) = UPLOS.EQ.UPLO ISAME( 3 ) = TRANAS.EQ.TRANSA ISAME( 4 ) = DIAGS.EQ.DIAG ISAME( 5 ) = MS.EQ.M ISAME( 6 ) = NS.EQ.N ISAME( 7 ) = ALS.EQ.ALPHA ISAME( 8 ) = LZE( AS, AA, LAA ) ISAME( 9 ) = LDAS.EQ.LDA IF( NULL )THEN ISAME( 10 ) = LZE( BS, BB, LBB ) ELSE ISAME( 10 ) = LZERES( 'GE', ' ', M, N, BS, $ BB, LDB ) END IF ISAME( 11 ) = LDBS.EQ.LDB * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 50 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 50 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 150 END IF * IF( .NOT.NULL )THEN IF( SNAME( 4: 5 ).EQ.'MM' )THEN * * Check the result. * IF( LEFT )THEN CALL ZMMCH( TRANSA, 'N', M, N, M, $ ALPHA, A, NMAX, B, NMAX, $ ZERO, C, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL ZMMCH( 'N', TRANSA, M, N, N, $ ALPHA, B, NMAX, A, NMAX, $ ZERO, C, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN * * Compute approximation to original * matrix. * DO 70 J = 1, N DO 60 I = 1, M C( I, J ) = BB( I + ( J - 1 )* $ LDB ) BB( I + ( J - 1 )*LDB ) = ALPHA* $ B( I, J ) 60 CONTINUE 70 CONTINUE * IF( LEFT )THEN CALL ZMMCH( TRANSA, 'N', M, N, M, $ ONE, A, NMAX, C, NMAX, $ ZERO, B, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .FALSE. ) ELSE CALL ZMMCH( 'N', TRANSA, M, N, N, $ ONE, C, NMAX, A, NMAX, $ ZERO, B, NMAX, CT, G, $ BB, LDB, EPS, ERR, $ FATAL, NOUT, .FALSE. ) END IF END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 150 END IF * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * 120 CONTINUE * 130 CONTINUE * 140 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 160 * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M, $ N, ALPHA, LDA, LDB * 160 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ') ', $ ' .' ) 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of ZCHK3. * END SUBROUTINE ZCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G ) * * Tests ZHERK and ZSYRK. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) DOUBLE PRECISION RONE, RZERO PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX*16 A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), B( NMAX, NMAX ), $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ), $ C( NMAX, NMAX ), CC( NMAX*NMAX ), $ CS( NMAX*NMAX ), CT( NMAX ) DOUBLE PRECISION G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX*16 ALPHA, ALS, BETA, BETS DOUBLE PRECISION ERR, ERRMAX, RALPHA, RALS, RBETA, RBETS INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, $ NARGS, NC, NS LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS CHARACTER*2 ICHT, ICHU * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LZE, LZERES EXTERNAL LZE, LZERES * .. External Subroutines .. EXTERNAL ZHERK, ZMAKE, ZMMCH, ZSYRK * .. Intrinsic Functions .. INTRINSIC DCMPLX, MAX, DBLE * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHT/'NC'/, ICHU/'UL'/ * .. Executable Statements .. CONJ = SNAME( 2: 3 ).EQ.'HE' * NARGS = 10 NC = 0 RESET = .TRUE. ERRMAX = RZERO * DO 100 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N * DO 90 IK = 1, NIDIM K = IDIM( IK ) * DO 80 ICT = 1, 2 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'C' IF( TRAN.AND..NOT.CONJ ) $ TRANS = 'T' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA * * Generate the matrix A. * CALL ZMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO ) * DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U' * DO 60 IA = 1, NALF ALPHA = ALF( IA ) IF( CONJ )THEN RALPHA = DBLE( ALPHA ) ALPHA = DCMPLX( RALPHA, RZERO ) END IF * DO 50 IB = 1, NBET BETA = BET( IB ) IF( CONJ )THEN RBETA = DBLE( BETA ) BETA = DCMPLX( RBETA, RZERO ) END IF NULL = N.LE.0 IF( CONJ ) $ NULL = NULL.OR.( ( K.LE.0.OR.RALPHA.EQ. $ RZERO ).AND.RBETA.EQ.RONE ) * * Generate the matrix C. * CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, $ NMAX, CC, LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the subroutine. * UPLOS = UPLO TRANSS = TRANS NS = N KS = K IF( CONJ )THEN RALS = RALPHA ELSE ALS = ALPHA END IF DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA IF( CONJ )THEN RBETS = RBETA ELSE BETS = BETA END IF DO 20 I = 1, LCC CS( I ) = CC( I ) 20 CONTINUE LDCS = LDC * * Call the subroutine. * IF( CONJ )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, $ TRANS, N, K, RALPHA, LDA, RBETA, LDC IF( REWI ) $ REWIND NTRA CALL ZHERK( UPLO, TRANS, N, K, RALPHA, AA, $ LDA, RBETA, CC, LDC ) ELSE IF( TRACE ) $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, BETA, LDC IF( REWI ) $ REWIND NTRA CALL ZSYRK( UPLO, TRANS, N, K, ALPHA, AA, $ LDA, BETA, CC, LDC ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9992 ) FATAL = .TRUE. GO TO 120 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K IF( CONJ )THEN ISAME( 5 ) = RALS.EQ.RALPHA ELSE ISAME( 5 ) = ALS.EQ.ALPHA END IF ISAME( 6 ) = LZE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA IF( CONJ )THEN ISAME( 8 ) = RBETS.EQ.RBETA ELSE ISAME( 8 ) = BETS.EQ.BETA END IF IF( NULL )THEN ISAME( 9 ) = LZE( CS, CC, LCC ) ELSE ISAME( 9 ) = LZERES( SNAME( 2: 3 ), UPLO, N, $ N, CS, CC, LDC ) END IF ISAME( 10 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 30 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 30 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF * IF( .NOT.NULL )THEN * * Check the result column by column. * IF( CONJ )THEN TRANST = 'C' ELSE TRANST = 'T' END IF JC = 1 DO 40 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN CALL ZMMCH( TRANST, 'N', LJ, 1, K, $ ALPHA, A( 1, JJ ), NMAX, $ A( 1, J ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL ZMMCH( 'N', TRANST, LJ, 1, K, $ ALPHA, A( JJ, 1 ), NMAX, $ A( J, 1 ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 110 40 CONTINUE END IF * 50 CONTINUE * 60 CONTINUE * 70 CONTINUE * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 130 * 110 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J * 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME IF( CONJ )THEN WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, RALPHA, $ LDA, RBETA, LDC ELSE WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, BETA, LDC END IF * 130 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') ', $ ' .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, ') , A,', I3, ',(', F4.1, ',', F4.1, $ '), C,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of ZCHK4. * END SUBROUTINE ZCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W ) * * Tests ZHER2K and ZSYR2K. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) DOUBLE PRECISION RONE, RZERO PARAMETER ( RONE = 1.0D0, RZERO = 0.0D0 ) * .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA LOGICAL FATAL, REWI, TRACE CHARACTER*6 SNAME * .. Array Arguments .. COMPLEX*16 AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ W( 2*NMAX ) DOUBLE PRECISION G( NMAX ) INTEGER IDIM( NIDIM ) * .. Local Scalars .. COMPLEX*16 ALPHA, ALS, BETA, BETS DOUBLE PRECISION ERR, ERRMAX, RBETA, RBETS INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS LOGICAL CONJ, NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, TRANST, UPLO, UPLOS CHARACTER*2 ICHT, ICHU * .. Local Arrays .. LOGICAL ISAME( 13 ) * .. External Functions .. LOGICAL LZE, LZERES EXTERNAL LZE, LZERES * .. External Subroutines .. EXTERNAL ZHER2K, ZMAKE, ZMMCH, ZSYR2K * .. Intrinsic Functions .. INTRINSIC DCMPLX, DCONJG, MAX, DBLE * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Data statements .. DATA ICHT/'NC'/, ICHU/'UL'/ * .. Executable Statements .. CONJ = SNAME( 2: 3 ).EQ.'HE' * NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = RZERO * DO 130 IN = 1, NIDIM N = IDIM( IN ) * Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1 * Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 130 LCC = LDC*N * DO 120 IK = 1, NIDIM K = IDIM( IK ) * DO 110 ICT = 1, 2 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'C' IF( TRAN.AND..NOT.CONJ ) $ TRANS = 'T' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF * Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1 * Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 110 LAA = LDA*NA * * Generate the matrix A. * IF( TRAN )THEN CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA, $ LDA, RESET, ZERO ) ELSE CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA, $ RESET, ZERO ) END IF * * Generate the matrix B. * LDB = LDA LBB = LAA IF( TRAN )THEN CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ), $ 2*NMAX, BB, LDB, RESET, ZERO ) ELSE CALL ZMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ), $ NMAX, BB, LDB, RESET, ZERO ) END IF * DO 100 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U' * DO 90 IA = 1, NALF ALPHA = ALF( IA ) * DO 80 IB = 1, NBET BETA = BET( IB ) IF( CONJ )THEN RBETA = DBLE( BETA ) BETA = DCMPLX( RBETA, RZERO ) END IF NULL = N.LE.0 IF( CONJ ) $ NULL = NULL.OR.( ( K.LE.0.OR.ALPHA.EQ. $ ZERO ).AND.RBETA.EQ.RONE ) * * Generate the matrix C. * CALL ZMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, C, $ NMAX, CC, LDC, RESET, ZERO ) * NC = NC + 1 * * Save every datum before calling the subroutine. * UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LBB BS( I ) = BB( I ) 20 CONTINUE LDBS = LDB IF( CONJ )THEN RBETS = RBETA ELSE BETS = BETA END IF DO 30 I = 1, LCC CS( I ) = CC( I ) 30 CONTINUE LDCS = LDC * * Call the subroutine. * IF( CONJ )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, LDB, RBETA, LDC IF( REWI ) $ REWIND NTRA CALL ZHER2K( UPLO, TRANS, N, K, ALPHA, AA, $ LDA, BB, LDB, RBETA, CC, LDC ) ELSE IF( TRACE ) $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC IF( REWI ) $ REWIND NTRA CALL ZSYR2K( UPLO, TRANS, N, K, ALPHA, AA, $ LDA, BB, LDB, BETA, CC, LDC ) END IF * * Check if error-exit was taken incorrectly. * IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9992 ) FATAL = .TRUE. GO TO 150 END IF * * See what data changed inside subroutines. * ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LZE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = LZE( BS, BB, LBB ) ISAME( 9 ) = LDBS.EQ.LDB IF( CONJ )THEN ISAME( 10 ) = RBETS.EQ.RBETA ELSE ISAME( 10 ) = BETS.EQ.BETA END IF IF( NULL )THEN ISAME( 11 ) = LZE( CS, CC, LCC ) ELSE ISAME( 11 ) = LZERES( 'HE', UPLO, N, N, CS, $ CC, LDC ) END IF ISAME( 12 ) = LDCS.EQ.LDC * * If data was incorrectly changed, report and * return. * SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 150 END IF * IF( .NOT.NULL )THEN * * Check the result column by column. * IF( CONJ )THEN TRANST = 'C' ELSE TRANST = 'T' END IF JJAB = 1 JC = 1 DO 70 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN DO 50 I = 1, K W( I ) = ALPHA*AB( ( J - 1 )*2* $ NMAX + K + I ) IF( CONJ )THEN W( K + I ) = DCONJG( ALPHA )* $ AB( ( J - 1 )*2* $ NMAX + I ) ELSE W( K + I ) = ALPHA* $ AB( ( J - 1 )*2* $ NMAX + I ) END IF 50 CONTINUE CALL ZMMCH( TRANST, 'N', LJ, 1, 2*K, $ ONE, AB( JJAB ), 2*NMAX, W, $ 2*NMAX, BETA, C( JJ, J ), $ NMAX, CT, G, CC( JC ), LDC, $ EPS, ERR, FATAL, NOUT, $ .TRUE. ) ELSE DO 60 I = 1, K IF( CONJ )THEN W( I ) = ALPHA*DCONJG( AB( ( K + $ I - 1 )*NMAX + J ) ) W( K + I ) = DCONJG( ALPHA* $ AB( ( I - 1 )*NMAX + $ J ) ) ELSE W( I ) = ALPHA*AB( ( K + I - 1 )* $ NMAX + J ) W( K + I ) = ALPHA* $ AB( ( I - 1 )*NMAX + $ J ) END IF 60 CONTINUE CALL ZMMCH( 'N', 'N', LJ, 1, 2*K, ONE, $ AB( JJ ), NMAX, W, 2*NMAX, $ BETA, C( JJ, J ), NMAX, CT, $ G, CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 IF( TRAN ) $ JJAB = JJAB + 2*NMAX END IF ERRMAX = MAX( ERRMAX, ERR ) * If got really bad answer, report and * return. IF( FATAL ) $ GO TO 140 70 CONTINUE END IF * 80 CONTINUE * 90 CONTINUE * 100 CONTINUE * 110 CONTINUE * 120 CONTINUE * 130 CONTINUE * * Report result. * IF( ERRMAX.LT.THRESH )THEN WRITE( NOUT, FMT = 9999 )SNAME, NC ELSE WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX END IF GO TO 160 * 140 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J * 150 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME IF( CONJ )THEN WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, LDB, RBETA, LDC ELSE WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, N, K, ALPHA, $ LDA, LDB, BETA, LDC END IF * 160 CONTINUE RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL', $ 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',', F4.1, $ ', C,', I3, ') .' ) 9993 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ '(', F4.1, ',', F4.1, '), A,', I3, ', B,', I3, ',(', F4.1, $ ',', F4.1, '), C,', I3, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' ) * * End of ZCHK5. * END SUBROUTINE ZCHKE( ISNUM, SRNAMT, NOUT ) * * Tests the error exits from the Level 3 Blas. * Requires a special version of the error-handling routine XERBLA. * ALPHA, RALPHA, BETA, RBETA, A, B and C should not need to be defined. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER ISNUM, NOUT CHARACTER*6 SRNAMT * .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL LERR, OK * .. Local Scalars .. COMPLEX*16 ALPHA, BETA DOUBLE PRECISION RALPHA, RBETA * .. Local Arrays .. COMPLEX*16 A( 2, 1 ), B( 2, 1 ), C( 2, 1 ) * .. External Subroutines .. EXTERNAL ZGEMM, ZHEMM, ZHER2K, ZHERK, CHKXER, ZSYMM, $ ZSYR2K, ZSYRK, ZTRMM, ZTRSM * .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK, LERR * .. Executable Statements .. * OK is set to .FALSE. by the special version of XERBLA or by CHKXER * if anything is wrong. OK = .TRUE. * LERR is set to .TRUE. by the special version of XERBLA each time * it is called, and is then tested and re-set by CHKXER. LERR = .FALSE. GO TO ( 10, 20, 30, 40, 50, 60, 70, 80, $ 90 )ISNUM 10 INFOT = 1 CALL ZGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 CALL ZGEMM( '/', 'C', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 1 CALL ZGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZGEMM( 'C', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'N', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'C', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'C', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'C', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'T', 'C', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'N', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'C', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'C', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'C', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'T', 'C', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'N', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'C', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'C', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'C', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'T', 'C', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'C', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'C', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'T', 'C', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 8 CALL ZGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'C', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'N', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'C', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'T', 'C', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'C', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'N', 'C', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'C', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'C', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'C', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'T', 'C', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 13 CALL ZGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 20 INFOT = 1 CALL ZHEMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZHEMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHEMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHEMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHEMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHEMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHEMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHEMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHEMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHEMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHEMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHEMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZHEMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZHEMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZHEMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZHEMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 30 INFOT = 1 CALL ZSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 40 INFOT = 1 CALL ZTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 50 INFOT = 1 CALL ZTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'L', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'R', 'U', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'L', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'R', 'L', 'C', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 5 CALL ZTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'L', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'R', 'U', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'L', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'R', 'L', 'C', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 6 CALL ZTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'R', 'U', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'R', 'L', 'C', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'L', 'U', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'R', 'U', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'L', 'L', 'C', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'R', 'L', 'C', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 11 CALL ZTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 60 INFOT = 1 CALL ZHERK( '/', 'N', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZHERK( 'U', 'T', 0, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHERK( 'U', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHERK( 'U', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHERK( 'L', 'N', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHERK( 'L', 'C', -1, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHERK( 'U', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHERK( 'U', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHERK( 'L', 'N', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHERK( 'L', 'C', 0, -1, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHERK( 'U', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHERK( 'L', 'C', 0, 2, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZHERK( 'U', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZHERK( 'U', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZHERK( 'L', 'N', 2, 0, RALPHA, A, 2, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZHERK( 'L', 'C', 2, 0, RALPHA, A, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 70 INFOT = 1 CALL ZSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZSYRK( 'U', 'C', 0, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 10 CALL ZSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 80 INFOT = 1 CALL ZHER2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZHER2K( 'U', 'T', 0, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHER2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHER2K( 'U', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHER2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZHER2K( 'L', 'C', -1, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHER2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHER2K( 'U', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHER2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZHER2K( 'L', 'C', 0, -1, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZHER2K( 'U', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, RBETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZHER2K( 'L', 'C', 0, 2, ALPHA, A, 2, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZHER2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZHER2K( 'U', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZHER2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZHER2K( 'L', 'C', 2, 0, ALPHA, A, 1, B, 1, RBETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) GO TO 100 90 INFOT = 1 CALL ZSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 2 CALL ZSYR2K( 'U', 'C', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 3 CALL ZSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 4 CALL ZSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 7 CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 9 CALL ZSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) INFOT = 12 CALL ZSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 ) CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * 100 IF( OK )THEN WRITE( NOUT, FMT = 9999 )SRNAMT ELSE WRITE( NOUT, FMT = 9998 )SRNAMT END IF RETURN * 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' ) 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****', $ '**' ) * * End of ZCHKE. * END SUBROUTINE ZMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET, $ TRANSL ) * * Generates values for an M by N matrix A. * Stores the values in the array AA in the data structure required * by the routine, with unwanted elements set to rogue value. * * TYPE is 'GE', 'HE', 'SY' or 'TR'. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX*16 ZERO, ONE PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ), $ ONE = ( 1.0D0, 0.0D0 ) ) COMPLEX*16 ROGUE PARAMETER ( ROGUE = ( -1.0D10, 1.0D10 ) ) DOUBLE PRECISION RZERO PARAMETER ( RZERO = 0.0D0 ) DOUBLE PRECISION RROGUE PARAMETER ( RROGUE = -1.0D10 ) * .. Scalar Arguments .. COMPLEX*16 TRANSL INTEGER LDA, M, N, NMAX LOGICAL RESET CHARACTER*1 DIAG, UPLO CHARACTER*2 TYPE * .. Array Arguments .. COMPLEX*16 A( NMAX, * ), AA( * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J, JJ LOGICAL GEN, HER, LOWER, SYM, TRI, UNIT, UPPER * .. External Functions .. COMPLEX*16 ZBEG EXTERNAL ZBEG * .. Intrinsic Functions .. INTRINSIC DCMPLX, DCONJG, DBLE * .. Executable Statements .. GEN = TYPE.EQ.'GE' HER = TYPE.EQ.'HE' SYM = TYPE.EQ.'SY' TRI = TYPE.EQ.'TR' UPPER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'U' LOWER = ( HER.OR.SYM.OR.TRI ).AND.UPLO.EQ.'L' UNIT = TRI.AND.DIAG.EQ.'U' * * Generate data in array A. * DO 20 J = 1, N DO 10 I = 1, M IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) ) $ THEN A( I, J ) = ZBEG( RESET ) + TRANSL IF( I.NE.J )THEN * Set some elements to zero IF( N.GT.3.AND.J.EQ.N/2 ) $ A( I, J ) = ZERO IF( HER )THEN A( J, I ) = DCONJG( A( I, J ) ) ELSE IF( SYM )THEN A( J, I ) = A( I, J ) ELSE IF( TRI )THEN A( J, I ) = ZERO END IF END IF END IF 10 CONTINUE IF( HER ) $ A( J, J ) = DCMPLX( DBLE( A( J, J ) ), RZERO ) IF( TRI ) $ A( J, J ) = A( J, J ) + ONE IF( UNIT ) $ A( J, J ) = ONE 20 CONTINUE * * Store elements in array AS in data structure required by routine. * IF( TYPE.EQ.'GE' )THEN DO 50 J = 1, N DO 30 I = 1, M AA( I + ( J - 1 )*LDA ) = A( I, J ) 30 CONTINUE DO 40 I = M + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 40 CONTINUE 50 CONTINUE ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN DO 90 J = 1, N IF( UPPER )THEN IBEG = 1 IF( UNIT )THEN IEND = J - 1 ELSE IEND = J END IF ELSE IF( UNIT )THEN IBEG = J + 1 ELSE IBEG = J END IF IEND = N END IF DO 60 I = 1, IBEG - 1 AA( I + ( J - 1 )*LDA ) = ROGUE 60 CONTINUE DO 70 I = IBEG, IEND AA( I + ( J - 1 )*LDA ) = A( I, J ) 70 CONTINUE DO 80 I = IEND + 1, LDA AA( I + ( J - 1 )*LDA ) = ROGUE 80 CONTINUE IF( HER )THEN JJ = J + ( J - 1 )*LDA AA( JJ ) = DCMPLX( DBLE( AA( JJ ) ), RROGUE ) END IF 90 CONTINUE END IF RETURN * * End of ZMAKE. * END SUBROUTINE ZMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL, $ NOUT, MV ) * * Checks the results of the computational tests. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D0, 0.0D0 ) ) DOUBLE PRECISION RZERO, RONE PARAMETER ( RZERO = 0.0D0, RONE = 1.0D0 ) * .. Scalar Arguments .. COMPLEX*16 ALPHA, BETA DOUBLE PRECISION EPS, ERR INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT LOGICAL FATAL, MV CHARACTER*1 TRANSA, TRANSB * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ), $ CC( LDCC, * ), CT( * ) DOUBLE PRECISION G( * ) * .. Local Scalars .. COMPLEX*16 CL DOUBLE PRECISION ERRI INTEGER I, J, K LOGICAL CTRANA, CTRANB, TRANA, TRANB * .. Intrinsic Functions .. INTRINSIC ABS, DIMAG, DCONJG, MAX, DBLE, SQRT * .. Statement Functions .. DOUBLE PRECISION ABS1 * .. Statement Function definitions .. ABS1( CL ) = ABS( DBLE( CL ) ) + ABS( DIMAG( CL ) ) * .. Executable Statements .. TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C' TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C' CTRANA = TRANSA.EQ.'C' CTRANB = TRANSB.EQ.'C' * * Compute expected result, one column at a time, in CT using data * in A, B and C. * Compute gauges in G. * DO 220 J = 1, N * DO 10 I = 1, M CT( I ) = ZERO G( I ) = RZERO 10 CONTINUE IF( .NOT.TRANA.AND..NOT.TRANB )THEN DO 30 K = 1, KK DO 20 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( K, J ) G( I ) = G( I ) + ABS1( A( I, K ) )*ABS1( B( K, J ) ) 20 CONTINUE 30 CONTINUE ELSE IF( TRANA.AND..NOT.TRANB )THEN IF( CTRANA )THEN DO 50 K = 1, KK DO 40 I = 1, M CT( I ) = CT( I ) + DCONJG( A( K, I ) )*B( K, J ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( K, J ) ) 40 CONTINUE 50 CONTINUE ELSE DO 70 K = 1, KK DO 60 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( K, J ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( K, J ) ) 60 CONTINUE 70 CONTINUE END IF ELSE IF( .NOT.TRANA.AND.TRANB )THEN IF( CTRANB )THEN DO 90 K = 1, KK DO 80 I = 1, M CT( I ) = CT( I ) + A( I, K )*DCONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( I, K ) )* $ ABS1( B( J, K ) ) 80 CONTINUE 90 CONTINUE ELSE DO 110 K = 1, KK DO 100 I = 1, M CT( I ) = CT( I ) + A( I, K )*B( J, K ) G( I ) = G( I ) + ABS1( A( I, K ) )* $ ABS1( B( J, K ) ) 100 CONTINUE 110 CONTINUE END IF ELSE IF( TRANA.AND.TRANB )THEN IF( CTRANA )THEN IF( CTRANB )THEN DO 130 K = 1, KK DO 120 I = 1, M CT( I ) = CT( I ) + DCONJG( A( K, I ) )* $ DCONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( J, K ) ) 120 CONTINUE 130 CONTINUE ELSE DO 150 K = 1, KK DO 140 I = 1, M CT( I ) = CT( I ) + DCONJG( A( K, I ) )* $ B( J, K ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( J, K ) ) 140 CONTINUE 150 CONTINUE END IF ELSE IF( CTRANB )THEN DO 170 K = 1, KK DO 160 I = 1, M CT( I ) = CT( I ) + A( K, I )* $ DCONJG( B( J, K ) ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( J, K ) ) 160 CONTINUE 170 CONTINUE ELSE DO 190 K = 1, KK DO 180 I = 1, M CT( I ) = CT( I ) + A( K, I )*B( J, K ) G( I ) = G( I ) + ABS1( A( K, I ) )* $ ABS1( B( J, K ) ) 180 CONTINUE 190 CONTINUE END IF END IF END IF DO 200 I = 1, M CT( I ) = ALPHA*CT( I ) + BETA*C( I, J ) G( I ) = ABS1( ALPHA )*G( I ) + $ ABS1( BETA )*ABS1( C( I, J ) ) 200 CONTINUE * * Compute the error ratio for this result. * ERR = ZERO DO 210 I = 1, M ERRI = ABS1( CT( I ) - CC( I, J ) )/EPS IF( G( I ).NE.RZERO ) $ ERRI = ERRI/G( I ) ERR = MAX( ERR, ERRI ) IF( ERR*SQRT( EPS ).GE.RONE ) $ GO TO 230 210 CONTINUE * 220 CONTINUE * * If the loop completes, all results are at least half accurate. GO TO 250 * * Report fatal error. * 230 FATAL = .TRUE. WRITE( NOUT, FMT = 9999 ) DO 240 I = 1, M IF( MV )THEN WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J ) ELSE WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I ) END IF 240 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9997 )J * 250 CONTINUE RETURN * 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL', $ 'F ACCURATE *******', /' EXPECTED RE', $ 'SULT COMPUTED RESULT' ) 9998 FORMAT( 1X, I7, 2( ' (', G15.6, ',', G15.6, ')' ) ) 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) * * End of ZMMCH. * END LOGICAL FUNCTION LZE( RI, RJ, LR ) * * Tests if two arrays are identical. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER LR * .. Array Arguments .. COMPLEX*16 RI( * ), RJ( * ) * .. Local Scalars .. INTEGER I * .. Executable Statements .. DO 10 I = 1, LR IF( RI( I ).NE.RJ( I ) ) $ GO TO 20 10 CONTINUE LZE = .TRUE. GO TO 30 20 CONTINUE LZE = .FALSE. 30 RETURN * * End of LZE. * END LOGICAL FUNCTION LZERES( TYPE, UPLO, M, N, AA, AS, LDA ) * * Tests if selected elements in two arrays are equal. * * TYPE is 'GE' or 'HE' or 'SY'. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER LDA, M, N CHARACTER*1 UPLO CHARACTER*2 TYPE * .. Array Arguments .. COMPLEX*16 AA( LDA, * ), AS( LDA, * ) * .. Local Scalars .. INTEGER I, IBEG, IEND, J LOGICAL UPPER * .. Executable Statements .. UPPER = UPLO.EQ.'U' IF( TYPE.EQ.'GE' )THEN DO 20 J = 1, N DO 10 I = M + 1, LDA IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 10 CONTINUE 20 CONTINUE ELSE IF( TYPE.EQ.'HE'.OR.TYPE.EQ.'SY' )THEN DO 50 J = 1, N IF( UPPER )THEN IBEG = 1 IEND = J ELSE IBEG = J IEND = N END IF DO 30 I = 1, IBEG - 1 IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 30 CONTINUE DO 40 I = IEND + 1, LDA IF( AA( I, J ).NE.AS( I, J ) ) $ GO TO 70 40 CONTINUE 50 CONTINUE END IF * 60 CONTINUE LZERES = .TRUE. GO TO 80 70 CONTINUE LZERES = .FALSE. 80 RETURN * * End of LZERES. * END COMPLEX*16 FUNCTION ZBEG( RESET ) * * Generates complex numbers as pairs of random numbers uniformly * distributed between -0.5 and 0.5. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. LOGICAL RESET * .. Local Scalars .. INTEGER I, IC, J, MI, MJ * .. Save statement .. SAVE I, IC, J, MI, MJ * .. Intrinsic Functions .. INTRINSIC DCMPLX * .. Executable Statements .. IF( RESET )THEN * Initialize local variables. MI = 891 MJ = 457 I = 7 J = 7 IC = 0 RESET = .FALSE. END IF * * The sequence of values of I or J is bounded between 1 and 999. * If initial I or J = 1,2,3,6,7 or 9, the period will be 50. * If initial I or J = 4 or 8, the period will be 25. * If initial I or J = 5, the period will be 10. * IC is used to break up the period by skipping 1 value of I or J * in 6. * IC = IC + 1 10 I = I*MI J = J*MJ I = I - 1000*( I/1000 ) J = J - 1000*( J/1000 ) IF( IC.GE.5 )THEN IC = 0 GO TO 10 END IF ZBEG = DCMPLX( ( I - 500 )/1001.0D0, ( J - 500 )/1001.0D0 ) RETURN * * End of ZBEG. * END DOUBLE PRECISION FUNCTION DDIFF( X, Y ) * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. DOUBLE PRECISION X, Y * .. Executable Statements .. DDIFF = X - Y RETURN * * End of DDIFF. * END SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK ) * * Tests whether XERBLA has detected an error when it should. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER INFOT, NOUT LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Executable Statements .. IF( .NOT.LERR )THEN WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT OK = .FALSE. END IF LERR = .FALSE. RETURN * 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D', $ 'ETECTED BY ', A6, ' *****' ) * * End of CHKXER. * END SUBROUTINE XERBLA( SRNAME, INFO ) * * This is a special version of XERBLA to be used only as part of * the test program for testing error exits from the Level 3 BLAS * routines. * * XERBLA is an error handler for the Level 3 BLAS routines. * * It is called by the Level 3 BLAS routines if an input parameter is * invalid. * * Auxiliary routine for test program for Level 3 Blas. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * .. Scalar Arguments .. INTEGER INFO CHARACTER*6 SRNAME * .. Scalars in Common .. INTEGER INFOT, NOUT LOGICAL LERR, OK CHARACTER*6 SRNAMT * .. Common blocks .. COMMON /INFOC/INFOT, NOUT, OK, LERR COMMON /SRNAMC/SRNAMT * .. Executable Statements .. LERR = .TRUE. IF( INFO.NE.INFOT )THEN IF( INFOT.NE.0 )THEN WRITE( NOUT, FMT = 9999 )INFO, INFOT ELSE WRITE( NOUT, FMT = 9997 )INFO END IF OK = .FALSE. END IF IF( SRNAME.NE.SRNAMT )THEN WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT OK = .FALSE. END IF RETURN * 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD', $ ' OF ', I2, ' *******' ) 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE', $ 'AD OF ', A6, ' *******' ) 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, $ ' *******' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'cblat3.in' then echo shar: will not over-write existing file "'cblat3.in'" else cat << SHAR_EOF > 'cblat3.in' 'CBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE 6 UNIT NUMBER OF SUMMARY FILE 'CBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. F LOGICAL FLAG, T TO STOP ON FAILURES. T LOGICAL FLAG, T TO TEST ERROR EXITS. 16.0 THRESHOLD VALUE OF TEST RATIO 11 NUMBER OF VALUES OF N 0 1 2 3 4 5 63 64 127 128 136 VALUES OF N 3 NUMBER OF VALUES OF ALPHA (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA CGEMM F PUT F FOR NO TEST. SAME COLUMNS. CHEMM T PUT F FOR NO TEST. SAME COLUMNS. CSYMM T PUT F FOR NO TEST. SAME COLUMNS. CTRMM T PUT F FOR NO TEST. SAME COLUMNS. CTRSM T PUT F FOR NO TEST. SAME COLUMNS. CHERK T PUT F FOR NO TEST. SAME COLUMNS. CSYRK T PUT F FOR NO TEST. SAME COLUMNS. CHER2K T PUT F FOR NO TEST. SAME COLUMNS. CSYR2K T PUT F FOR NO TEST. SAME COLUMNS. SHAR_EOF fi # end of overwriting check if test -f 'dblat3.in' then echo shar: will not over-write existing file "'dblat3.in'" else cat << SHAR_EOF > 'dblat3.in' 'DBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE 6 UNIT NUMBER OF SUMMARY FILE 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. F LOGICAL FLAG, T TO STOP ON FAILURES. T LOGICAL FLAG, T TO TEST ERROR EXITS. 16.0 THRESHOLD VALUE OF TEST RATIO 11 NUMBER OF VALUES OF N 0 1 2 3 4 5 63 64 127 128 136 VALUES OF N 3 NUMBER OF VALUES OF ALPHA 0.0 1.0 0.7 VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA 0.0 1.0 1.3 VALUES OF BETA DGEMM F PUT F FOR NO TEST. SAME COLUMNS. DSYMM T PUT F FOR NO TEST. SAME COLUMNS. DTRMM T PUT F FOR NO TEST. SAME COLUMNS. DTRSM T PUT F FOR NO TEST. SAME COLUMNS. DSYRK T PUT F FOR NO TEST. SAME COLUMNS. DSYR2K T PUT F FOR NO TEST. SAME COLUMNS. SHAR_EOF fi # end of overwriting check if test -f 'sblat3.in' then echo shar: will not over-write existing file "'sblat3.in'" else cat << SHAR_EOF > 'sblat3.in' 'SBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE 6 UNIT NUMBER OF SUMMARY FILE 'SBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. F LOGICAL FLAG, T TO STOP ON FAILURES. T LOGICAL FLAG, T TO TEST ERROR EXITS. 16.0 THRESHOLD VALUE OF TEST RATIO 11 NUMBER OF VALUES OF N 0 1 2 3 4 5 63 64 127 128 136 VALUES OF N 3 NUMBER OF VALUES OF ALPHA 0.0 1.0 0.7 VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA 0.0 1.0 1.3 VALUES OF BETA SGEMM F PUT F FOR NO TEST. SAME COLUMNS. SSYMM T PUT F FOR NO TEST. SAME COLUMNS. STRMM T PUT F FOR NO TEST. SAME COLUMNS. STRSM T PUT F FOR NO TEST. SAME COLUMNS. SSYRK T PUT F FOR NO TEST. SAME COLUMNS. SSYR2K T PUT F FOR NO TEST. SAME COLUMNS. SHAR_EOF fi # end of overwriting check if test -f 'zblat3.in' then echo shar: will not over-write existing file "'zblat3.in'" else cat << SHAR_EOF > 'zblat3.in' 'ZBLAT3.SUMM' NAME OF SUMMARY OUTPUT FILE 6 UNIT NUMBER OF SUMMARY FILE 'ZBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0) F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD. F LOGICAL FLAG, T TO STOP ON FAILURES. T LOGICAL FLAG, T TO TEST ERROR EXITS. 16.0 THRESHOLD VALUE OF TEST RATIO 11 NUMBER OF VALUES OF N 0 1 2 3 4 5 63 64 79 80 104 VALUES OF N 3 NUMBER OF VALUES OF ALPHA (0.0,0.0) (1.0,0.0) (0.7,-0.9) VALUES OF ALPHA 3 NUMBER OF VALUES OF BETA (0.0,0.0) (1.0,0.0) (1.3,-1.1) VALUES OF BETA ZGEMM F PUT F FOR NO TEST. SAME COLUMNS. ZHEMM T PUT F FOR NO TEST. SAME COLUMNS. ZSYMM T PUT F FOR NO TEST. SAME COLUMNS. ZTRMM T PUT F FOR NO TEST. SAME COLUMNS. ZTRSM T PUT F FOR NO TEST. SAME COLUMNS. ZHERK T PUT F FOR NO TEST. SAME COLUMNS. ZSYRK T PUT F FOR NO TEST. SAME COLUMNS. ZHER2K T PUT F FOR NO TEST. SAME COLUMNS. ZSYR2K T PUT F FOR NO TEST. SAME COLUMNS. SHAR_EOF fi # end of overwriting check cd .. cd .. if test ! -d 'UNDERLIB' then mkdir 'UNDERLIB' fi cd 'UNDERLIB' if test -f 'Makefile' then echo shar: will not over-write existing file "'Makefile'" else cat << SHAR_EOF > 'Makefile' include ../make.inc ### Underlying BLAS #################################################### ULIB = $(CREULIB) DGBS = saxpy.f scopy.f sgemm.f sgemv.f sger.f sscal.f ssyr.f \ strmv.f strsv.f daxpy.f dcopy.f dcabs1.f dgemm.f dgemv.f \ dger.f dscal.f dsyr.f dtrmv.f dtrsv.f caxpy.f ccopy.f \ cgemm.f cgemv.f cher.f cscal.f ctrmv.f ctrsv.f zaxpy.f \ zcopy.f zgemm.f zgemv.f zher.f zscal.f ztrmv.f ztrsv.f \ lsame.f xerbla.f DGB = saxpy.o scopy.o sgemm.o sgemv.o sger.o sscal.o ssyr.o \ strmv.o strsv.o daxpy.o dcopy.o dcabs1.o dgemm.o dgemv.o \ dger.o dscal.o dsyr.o dtrmv.o dtrsv.o caxpy.o ccopy.o \ cgemm.o cgemv.o cher.o cscal.o ctrmv.o ctrsv.o zaxpy.o \ zcopy.o zgemm.o zgemv.o zher.o zscal.o ztrmv.o ztrsv.o \ lsame.o xerbla.o ######################################################################## all: $(CREULIB) $(CREULIB): $(DGB) $(ARCH) $(ARCHFLAGS) $(ULIB) $(DGB) $(RANLIB) $(ULIB) $(DGB): $(DGBS) $(FORTRAN) -c $(UNDEROPT) $(DGBS) clean: rm -f *.o SHAR_EOF fi # end of overwriting check if test -f 'caxpy.f' then echo shar: will not over-write existing file "'caxpy.f'" else cat << SHAR_EOF > 'caxpy.f' subroutine caxpy(n,ca,cx,incx,cy,incy) c c constant times a vector plus a vector. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c complex cx(*),cy(*),ca integer i,incx,incy,ix,iy,n c if(n.le.0)return if (abs(real(ca)) + abs(aimag(ca)) .eq. 0.0 ) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n cy(iy) = cy(iy) + ca*cx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n cy(i) = cy(i) + ca*cx(i) 30 continue return end SHAR_EOF fi # end of overwriting check if test -f 'ccopy.f' then echo shar: will not over-write existing file "'ccopy.f'" else cat << SHAR_EOF > 'ccopy.f' subroutine ccopy(n,cx,incx,cy,incy) c c copies a vector, x, to a vector, y. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c complex cx(*),cy(*) integer i,incx,incy,ix,iy,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n cy(iy) = cx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n cy(i) = cx(i) 30 continue return end SHAR_EOF fi # end of overwriting check if test -f 'cgemm.f' then echo shar: will not over-write existing file "'cgemm.f'" else cat << SHAR_EOF > 'cgemm.f' SUBROUTINE CGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC COMPLEX ALPHA, BETA * .. Array Arguments .. COMPLEX A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * CGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = conjg( A' ). * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = conjg( B' ). * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - COMPLEX array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - COMPLEX . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. Local Scalars .. LOGICAL CONJA, CONJB, NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB COMPLEX TEMP * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * conjugated or transposed, set CONJA and CONJB as true if A and * B respectively are to be transposed but not conjugated and set * NROWA, NCOLA and NROWB as the number of rows and columns of A * and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) CONJA = LSAME( TRANSA, 'C' ) CONJB = LSAME( TRANSB, 'C' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.CONJA ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.CONJB ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE IF( CONJA )THEN * * Form C := alpha*conjg( A' )*B + beta*C. * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + CONJG( A( L, I ) )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 150, J = 1, N DO 140, I = 1, M TEMP = ZERO DO 130, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 130 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 140 CONTINUE 150 CONTINUE END IF ELSE IF( NOTA )THEN IF( CONJB )THEN * * Form C := alpha*A*conjg( B' ) + beta*C. * DO 200, J = 1, N IF( BETA.EQ.ZERO )THEN DO 160, I = 1, M C( I, J ) = ZERO 160 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 170, I = 1, M C( I, J ) = BETA*C( I, J ) 170 CONTINUE END IF DO 190, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*CONJG( B( J, L ) ) DO 180, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 180 CONTINUE END IF 190 CONTINUE 200 CONTINUE ELSE * * Form C := alpha*A*B' + beta*C * DO 250, J = 1, N IF( BETA.EQ.ZERO )THEN DO 210, I = 1, M C( I, J ) = ZERO 210 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 220, I = 1, M C( I, J ) = BETA*C( I, J ) 220 CONTINUE END IF DO 240, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 230, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 230 CONTINUE END IF 240 CONTINUE 250 CONTINUE END IF ELSE IF( CONJA )THEN IF( CONJB )THEN * * Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. * DO 280, J = 1, N DO 270, I = 1, M TEMP = ZERO DO 260, L = 1, K TEMP = TEMP + CONJG( A( L, I ) )*CONJG( B( J, L ) ) 260 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 270 CONTINUE 280 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B' + beta*C * DO 310, J = 1, N DO 300, I = 1, M TEMP = ZERO DO 290, L = 1, K TEMP = TEMP + CONJG( A( L, I ) )*B( J, L ) 290 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 300 CONTINUE 310 CONTINUE END IF ELSE IF( CONJB )THEN * * Form C := alpha*A'*conjg( B' ) + beta*C * DO 340, J = 1, N DO 330, I = 1, M TEMP = ZERO DO 320, L = 1, K TEMP = TEMP + A( L, I )*CONJG( B( J, L ) ) 320 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 330 CONTINUE 340 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 370, J = 1, N DO 360, I = 1, M TEMP = ZERO DO 350, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 350 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 360 CONTINUE 370 CONTINUE END IF END IF * RETURN * * End of CGEMM . * END SHAR_EOF fi # end of overwriting check if test -f 'cgemv.f' then echo shar: will not over-write existing file "'cgemv.f'" else cat << SHAR_EOF > 'cgemv.f' SUBROUTINE CGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. COMPLEX ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. COMPLEX A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * CGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or * * y := alpha*conjg( A' )*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * X - COMPLEX array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - COMPLEX . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - COMPLEX array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX ONE PARAMETER ( ONE = ( 1.0E+0, 0.0E+0 ) ) COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY LOGICAL NOCONJ * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 ELSE IF( INCY.EQ.0 )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CGEMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) * * Set LENX and LENY, the lengths of the vectors x and y, and set * up the start points in X and Y. * IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = ZERO IF( NOCONJ )THEN DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE DO 100, I = 1, M TEMP = TEMP + CONJG( A( I, J ) )*X( I ) 100 CONTINUE END IF Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 110 CONTINUE ELSE DO 140, J = 1, N TEMP = ZERO IX = KX IF( NOCONJ )THEN DO 120, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE ELSE DO 130, I = 1, M TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE END IF Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 140 CONTINUE END IF END IF * RETURN * * End of CGEMV . * END SHAR_EOF fi # end of overwriting check if test -f 'cher.f' then echo shar: will not over-write existing file "'cher.f'" else cat << SHAR_EOF > 'cher.f' SUBROUTINE CHER ( UPLO, N, ALPHA, X, INCX, A, LDA ) * .. Scalar Arguments .. REAL ALPHA INTEGER INCX, LDA, N CHARACTER*1 UPLO * .. Array Arguments .. COMPLEX A( LDA, * ), X( * ) * .. * * Purpose * ======= * * CHER performs the hermitian rank 1 operation * * A := alpha*x*conjg( x' ) + A, * * where alpha is a real scalar, x is an n element vector and A is an * n by n hermitian matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - COMPLEX array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of A is not referenced. On exit, the * upper triangular part of the array A is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of A is not referenced. On exit, the * lower triangular part of the array A is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, KX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC CONJG, MAX, REAL * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 7 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CHER ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR.( ALPHA.EQ.REAL( ZERO ) ) ) $ RETURN * * Set the start point in X if the increment is not unity. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * IF( LSAME( UPLO, 'U' ) )THEN * * Form A when A is stored in upper triangle. * IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*CONJG( X( J ) ) DO 10, I = 1, J - 1 A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE A( J, J ) = REAL( A( J, J ) ) + REAL( X( J )*TEMP ) ELSE A( J, J ) = REAL( A( J, J ) ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*CONJG( X( JX ) ) IX = KX DO 30, I = 1, J - 1 A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE A( J, J ) = REAL( A( J, J ) ) + REAL( X( JX )*TEMP ) ELSE A( J, J ) = REAL( A( J, J ) ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE * * Form A when A is stored in lower triangle. * IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*CONJG( X( J ) ) A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( J ) ) DO 50, I = J + 1, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE ELSE A( J, J ) = REAL( A( J, J ) ) END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*CONJG( X( JX ) ) A( J, J ) = REAL( A( J, J ) ) + REAL( TEMP*X( JX ) ) IX = JX DO 70, I = J + 1, N IX = IX + INCX A( I, J ) = A( I, J ) + X( IX )*TEMP 70 CONTINUE ELSE A( J, J ) = REAL( A( J, J ) ) END IF JX = JX + INCX 80 CONTINUE END IF END IF * RETURN * * End of CHER . * END SHAR_EOF fi # end of overwriting check if test -f 'cscal.f' then echo shar: will not over-write existing file "'cscal.f'" else cat << SHAR_EOF > 'cscal.f' subroutine cscal(n,ca,cx,incx) c c scales a vector by a constant. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c complex ca,cx(*) integer i,incx,n,nincx c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx cx(i) = ca*cx(i) 10 continue return c c code for increment equal to 1 c 20 do 30 i = 1,n cx(i) = ca*cx(i) 30 continue return end SHAR_EOF fi # end of overwriting check if test -f 'ctrmv.f' then echo shar: will not over-write existing file "'ctrmv.f'" else cat << SHAR_EOF > 'ctrmv.f' SUBROUTINE CTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. COMPLEX A( LDA, * ), X( * ) * .. * * Purpose * ======= * * CTRMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, or x := conjg( A' )*x, * * where x is an n element vector and A is an n by n unit, or non-unit, * upper or lower triangular matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' x := A*x. * * TRANS = 'T' or 't' x := A'*x. * * TRANS = 'C' or 'c' x := conjg( A' )*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - COMPLEX array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOCONJ, NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CTRMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := A*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX - INCX 80 CONTINUE END IF END IF ELSE * * Form x := A'*x or x := conjg( A' )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 110, J = N, 1, -1 TEMP = X( J ) IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*CONJG( A( J, J ) ) DO 100, I = J - 1, 1, -1 TEMP = TEMP + CONJG( A( I, J ) )*X( I ) 100 CONTINUE END IF X( J ) = TEMP 110 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 140, J = N, 1, -1 TEMP = X( JX ) IX = JX IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 120, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 120 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*CONJG( A( J, J ) ) DO 130, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) 130 CONTINUE END IF X( JX ) = TEMP JX = JX - INCX 140 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 170, J = 1, N TEMP = X( J ) IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 150 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*CONJG( A( J, J ) ) DO 160, I = J + 1, N TEMP = TEMP + CONJG( A( I, J ) )*X( I ) 160 CONTINUE END IF X( J ) = TEMP 170 CONTINUE ELSE JX = KX DO 200, J = 1, N TEMP = X( JX ) IX = JX IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 180, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 180 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*CONJG( A( J, J ) ) DO 190, I = J + 1, N IX = IX + INCX TEMP = TEMP + CONJG( A( I, J ) )*X( IX ) 190 CONTINUE END IF X( JX ) = TEMP JX = JX + INCX 200 CONTINUE END IF END IF END IF * RETURN * * End of CTRMV . * END SHAR_EOF fi # end of overwriting check if test -f 'ctrsv.f' then echo shar: will not over-write existing file "'ctrsv.f'" else cat << SHAR_EOF > 'ctrsv.f' SUBROUTINE CTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. COMPLEX A( LDA, * ), X( * ) * .. * * Purpose * ======= * * CTRSV solves one of the systems of equations * * A*x = b, or A'*x = b, or conjg( A' )*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' conjg( A' )*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - COMPLEX array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - COMPLEX array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX ZERO PARAMETER ( ZERO = ( 0.0E+0, 0.0E+0 ) ) * .. Local Scalars .. COMPLEX TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOCONJ, NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC CONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'CTRSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = X( J ) IF( NOCONJ )THEN DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 100, I = 1, J - 1 TEMP = TEMP - CONJG( A( I, J ) )*X( I ) 100 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/CONJG( A( J, J ) ) END IF X( J ) = TEMP 110 CONTINUE ELSE JX = KX DO 140, J = 1, N IX = KX TEMP = X( JX ) IF( NOCONJ )THEN DO 120, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 130, I = 1, J - 1 TEMP = TEMP - CONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/CONJG( A( J, J ) ) END IF X( JX ) = TEMP JX = JX + INCX 140 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 170, J = N, 1, -1 TEMP = X( J ) IF( NOCONJ )THEN DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 160, I = N, J + 1, -1 TEMP = TEMP - CONJG( A( I, J ) )*X( I ) 160 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/CONJG( A( J, J ) ) END IF X( J ) = TEMP 170 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 200, J = N, 1, -1 IX = KX TEMP = X( JX ) IF( NOCONJ )THEN DO 180, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 180 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 190, I = N, J + 1, -1 TEMP = TEMP - CONJG( A( I, J ) )*X( IX ) IX = IX - INCX 190 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/CONJG( A( J, J ) ) END IF X( JX ) = TEMP JX = JX - INCX 200 CONTINUE END IF END IF END IF * RETURN * * End of CTRSV . * END SHAR_EOF fi # end of overwriting check if test -f 'daxpy.f' then echo shar: will not over-write existing file "'daxpy.f'" else cat << SHAR_EOF > 'daxpy.f' subroutine daxpy(n,da,dx,incx,dy,incy) c c constant times a vector plus a vector. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*),da integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (da .eq. 0.0d0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dy(iy) = dy(iy) + da*dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dy(i) + da*dx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 dy(i) = dy(i) + da*dx(i) dy(i + 1) = dy(i + 1) + da*dx(i + 1) dy(i + 2) = dy(i + 2) + da*dx(i + 2) dy(i + 3) = dy(i + 3) + da*dx(i + 3) 50 continue return end SHAR_EOF fi # end of overwriting check if test -f 'dcabs1.f' then echo shar: will not over-write existing file "'dcabs1.f'" else cat << SHAR_EOF > 'dcabs1.f' double precision function dcabs1(z) double complex z,zz double precision t(2) equivalence (zz,t(1)) zz = z dcabs1 = dabs(t(1)) + dabs(t(2)) return end SHAR_EOF fi # end of overwriting check if test -f 'dcopy.f' then echo shar: will not over-write existing file "'dcopy.f'" else cat << SHAR_EOF > 'dcopy.f' subroutine dcopy(n,dx,incx,dy,incy) c c copies a vector, x, to a vector, y. c uses unrolled loops for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double precision dx(*),dy(*) integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n dy(iy) = dx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,7) if( m .eq. 0 ) go to 40 do 30 i = 1,m dy(i) = dx(i) 30 continue if( n .lt. 7 ) return 40 mp1 = m + 1 do 50 i = mp1,n,7 dy(i) = dx(i) dy(i + 1) = dx(i + 1) dy(i + 2) = dx(i + 2) dy(i + 3) = dx(i + 3) dy(i + 4) = dx(i + 4) dy(i + 5) = dx(i + 5) dy(i + 6) = dx(i + 6) 50 continue return end SHAR_EOF fi # end of overwriting check if test -f 'dgemm.f' then echo shar: will not over-write existing file "'dgemm.f'" else cat << SHAR_EOF > 'dgemm.f' SUBROUTINE DGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC DOUBLE PRECISION ALPHA, BETA * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * DGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X', * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = A'. * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = B'. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - DOUBLE PRECISION array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB DOUBLE PRECISION TEMP * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * transposed and set NROWA, NCOLA and NROWB as the number of rows * and columns of A and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And if alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF( NOTA )THEN * * Form C := alpha*A*B' + beta*C * DO 170, J = 1, N IF( BETA.EQ.ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE END IF DO 160, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE END IF 160 CONTINUE 170 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 190 CONTINUE 200 CONTINUE END IF END IF * RETURN * * End of DGEMM . * END SHAR_EOF fi # end of overwriting check if test -f 'dgemv.f' then echo shar: will not over-write existing file "'dgemv.f'" else cat << SHAR_EOF > 'dgemv.f' SUBROUTINE DGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * DGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * X - DOUBLE PRECISION array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - DOUBLE PRECISION. * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - DOUBLE PRECISION array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ONE , ZERO PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 ELSE IF( INCY.EQ.0 )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGEMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * Set LENX and LENY, the lengths of the vectors x and y, and set * up the start points in X and Y. * IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = ZERO DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX DO 110, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE END IF END IF * RETURN * * End of DGEMV . * END SHAR_EOF fi # end of overwriting check if test -f 'dger.f' then echo shar: will not over-write existing file "'dger.f'" else cat << SHAR_EOF > 'dger.f' SUBROUTINE DGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * DGER performs the rank 1 operation * * A := alpha*x*y' + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DGER ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of DGER . * END SHAR_EOF fi # end of overwriting check if test -f 'dscal.f' then echo shar: will not over-write existing file "'dscal.f'" else cat << SHAR_EOF > 'dscal.f' subroutine dscal(n,da,dx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to one. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double precision da,dx(*) integer i,incx,m,mp1,n,nincx c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dx(i) = da*dx(i) 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da*dx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da*dx(i) dx(i + 1) = da*dx(i + 1) dx(i + 2) = da*dx(i + 2) dx(i + 3) = da*dx(i + 3) dx(i + 4) = da*dx(i + 4) 50 continue return end SHAR_EOF fi # end of overwriting check if test -f 'dsyr.f' then echo shar: will not over-write existing file "'dsyr.f'" else cat << SHAR_EOF > 'dsyr.f' SUBROUTINE DSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, LDA, N CHARACTER*1 UPLO * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DSYR performs the symmetric rank 1 operation * * A := alpha*x*x' + A, * * where alpha is a real scalar, x is an n element vector and A is an * n by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of A is not referenced. On exit, the * upper triangular part of the array A is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of A is not referenced. On exit, the * lower triangular part of the array A is overwritten by the * lower triangular part of the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 7 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DSYR ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Set the start point in X if the increment is not unity. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * IF( LSAME( UPLO, 'U' ) )THEN * * Form A when A is stored in upper triangle. * IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*X( J ) DO 10, I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IX = KX DO 30, I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JX = JX + INCX 40 CONTINUE END IF ELSE * * Form A when A is stored in lower triangle. * IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*X( J ) DO 50, I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IX = JX DO 70, I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF * RETURN * * End of DSYR . * END SHAR_EOF fi # end of overwriting check if test -f 'dtrmv.f' then echo shar: will not over-write existing file "'dtrmv.f'" else cat << SHAR_EOF > 'dtrmv.f' SUBROUTINE DTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DTRMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, * * where x is an n element vector and A is an n by n unit, or non-unit, * upper or lower triangular matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' x := A*x. * * TRANS = 'T' or 't' x := A'*x. * * TRANS = 'C' or 'c' x := A'*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := A*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX - INCX 80 CONTINUE END IF END IF ELSE * * Form x := A'*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 110, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = 1, N TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 130, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of DTRMV . * END SHAR_EOF fi # end of overwriting check if test -f 'dtrsv.f' then echo shar: will not over-write existing file "'dtrsv.f'" else cat << SHAR_EOF > 'dtrsv.f' SUBROUTINE DTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), X( * ) * .. * * Purpose * ======= * * DTRSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - DOUBLE PRECISION array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - DOUBLE PRECISION array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. DOUBLE PRECISION ZERO PARAMETER ( ZERO = 0.0D+0 ) * .. Local Scalars .. DOUBLE PRECISION TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'DTRSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = X( J ) DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX + INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) DO 130, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX - INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of DTRSV . * END SHAR_EOF fi # end of overwriting check if test -f 'lsame.f' then echo shar: will not over-write existing file "'lsame.f'" else cat << SHAR_EOF > 'lsame.f' LOGICAL FUNCTION LSAME( CA, CB ) * * -- LAPACK auxiliary routine (version 2.0) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * September 30, 1994 * * .. Scalar Arguments .. CHARACTER CA, CB * .. * * Purpose * ======= * * LSAME returns .TRUE. if CA is the same letter as CB regardless of * case. * * Arguments * ========= * * CA (input) CHARACTER*1 * CB (input) CHARACTER*1 * CA and CB specify the single characters to be compared. * * ===================================================================== * * .. Intrinsic Functions .. INTRINSIC ICHAR * .. * .. Local Scalars .. INTEGER INTA, INTB, ZCODE * .. * .. Executable Statements .. * * Test if the characters are equal * LSAME = CA.EQ.CB IF( LSAME ) $ RETURN * * Now test for equivalence if both characters are alphabetic. * ZCODE = ICHAR( 'Z' ) * * Use 'Z' rather than 'A' so that ASCII can be detected on Prime * machines, on which ICHAR returns a value with bit 8 set. * ICHAR('A') on Prime machines returns 193 which is the same as * ICHAR('A') on an EBCDIC machine. * INTA = ICHAR( CA ) INTB = ICHAR( CB ) * IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN * * ASCII is assumed - ZCODE is the ASCII code of either lower or * upper case 'Z'. * IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32 IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32 * ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN * * EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or * upper case 'Z'. * IF( INTA.GE.129 .AND. INTA.LE.137 .OR. $ INTA.GE.145 .AND. INTA.LE.153 .OR. $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64 IF( INTB.GE.129 .AND. INTB.LE.137 .OR. $ INTB.GE.145 .AND. INTB.LE.153 .OR. $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64 * ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN * * ASCII is assumed, on Prime machines - ZCODE is the ASCII code * plus 128 of either lower or upper case 'Z'. * IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32 IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32 END IF LSAME = INTA.EQ.INTB * * RETURN * * End of LSAME * END SHAR_EOF fi # end of overwriting check if test -f 'saxpy.f' then echo shar: will not over-write existing file "'saxpy.f'" else cat << SHAR_EOF > 'saxpy.f' subroutine saxpy(n,sa,sx,incx,sy,incy) c c constant times a vector plus a vector. c uses unrolled loop for increments equal to one. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c real sx(*),sy(*),sa integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if (sa .eq. 0.0) return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n sy(iy) = sy(iy) + sa*sx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,4) if( m .eq. 0 ) go to 40 do 30 i = 1,m sy(i) = sy(i) + sa*sx(i) 30 continue if( n .lt. 4 ) return 40 mp1 = m + 1 do 50 i = mp1,n,4 sy(i) = sy(i) + sa*sx(i) sy(i + 1) = sy(i + 1) + sa*sx(i + 1) sy(i + 2) = sy(i + 2) + sa*sx(i + 2) sy(i + 3) = sy(i + 3) + sa*sx(i + 3) 50 continue return end SHAR_EOF fi # end of overwriting check if test -f 'scopy.f' then echo shar: will not over-write existing file "'scopy.f'" else cat << SHAR_EOF > 'scopy.f' subroutine scopy(n,sx,incx,sy,incy) c c copies a vector, x, to a vector, y. c uses unrolled loops for increments equal to 1. c jack dongarra, linpack, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c real sx(*),sy(*) integer i,incx,incy,ix,iy,m,mp1,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n sy(iy) = sx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c c c clean-up loop c 20 m = mod(n,7) if( m .eq. 0 ) go to 40 do 30 i = 1,m sy(i) = sx(i) 30 continue if( n .lt. 7 ) return 40 mp1 = m + 1 do 50 i = mp1,n,7 sy(i) = sx(i) sy(i + 1) = sx(i + 1) sy(i + 2) = sx(i + 2) sy(i + 3) = sx(i + 3) sy(i + 4) = sx(i + 4) sy(i + 5) = sx(i + 5) sy(i + 6) = sx(i + 6) 50 continue return end SHAR_EOF fi # end of overwriting check if test -f 'sgemm.f' then echo shar: will not over-write existing file "'sgemm.f'" else cat << SHAR_EOF > 'sgemm.f' SUBROUTINE SGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC REAL ALPHA, BETA * .. Array Arguments .. REAL A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * SGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X', * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = A'. * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = B'. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - REAL array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - REAL array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. Local Scalars .. LOGICAL NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB REAL TEMP * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * transposed and set NROWA, NCOLA and NROWB as the number of rows * and columns of A and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.LSAME( TRANSA, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.LSAME( TRANSB, 'C' ) ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And if alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE END IF ELSE IF( NOTA )THEN * * Form C := alpha*A*B' + beta*C * DO 170, J = 1, N IF( BETA.EQ.ZERO )THEN DO 130, I = 1, M C( I, J ) = ZERO 130 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 140, I = 1, M C( I, J ) = BETA*C( I, J ) 140 CONTINUE END IF DO 160, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 150, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 150 CONTINUE END IF 160 CONTINUE 170 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 200, J = 1, N DO 190, I = 1, M TEMP = ZERO DO 180, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 180 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 190 CONTINUE 200 CONTINUE END IF END IF * RETURN * * End of SGEMM . * END SHAR_EOF fi # end of overwriting check if test -f 'sgemv.f' then echo shar: will not over-write existing file "'sgemv.f'" else cat << SHAR_EOF > 'sgemv.f' SUBROUTINE SGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. REAL ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * SGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*A'*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * X - REAL array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - REAL . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - REAL array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ONE , ZERO PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 ELSE IF( INCY.EQ.0 )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGEMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * Set LENX and LENY, the lengths of the vectors x and y, and set * up the start points in X and Y. * IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = ZERO DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 100 CONTINUE ELSE DO 120, J = 1, N TEMP = ZERO IX = KX DO 110, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 120 CONTINUE END IF END IF * RETURN * * End of SGEMV . * END SHAR_EOF fi # end of overwriting check if test -f 'sger.f' then echo shar: will not over-write existing file "'sger.f'" else cat << SHAR_EOF > 'sger.f' SUBROUTINE SGER ( M, N, ALPHA, X, INCX, Y, INCY, A, LDA ) * .. Scalar Arguments .. REAL ALPHA INTEGER INCX, INCY, LDA, M, N * .. Array Arguments .. REAL A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * SGER performs the rank 1 operation * * A := alpha*x*y' + A, * * where alpha is a scalar, x is an m element vector, y is an n element * vector and A is an m by n matrix. * * Parameters * ========== * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( m - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the m * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * Y - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCY ) ). * Before entry, the incremented array Y must contain the n * element vector y. * Unchanged on exit. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. On exit, A is * overwritten by the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JY, KX * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( M.LT.0 )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( INCY.EQ.0 )THEN INFO = 7 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 9 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SGER ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( INCY.GT.0 )THEN JY = 1 ELSE JY = 1 - ( N - 1 )*INCY END IF IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) DO 10, I = 1, M A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF JY = JY + INCY 20 CONTINUE ELSE IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( M - 1 )*INCX END IF DO 40, J = 1, N IF( Y( JY ).NE.ZERO )THEN TEMP = ALPHA*Y( JY ) IX = KX DO 30, I = 1, M A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JY = JY + INCY 40 CONTINUE END IF * RETURN * * End of SGER . * END SHAR_EOF fi # end of overwriting check if test -f 'sscal.f' then echo shar: will not over-write existing file "'sscal.f'" else cat << SHAR_EOF > 'sscal.f' subroutine sscal(n,sa,sx,incx) c c scales a vector by a constant. c uses unrolled loops for increment equal to 1. c jack dongarra, linpack, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c real sa,sx(*) integer i,incx,m,mp1,n,nincx c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx sx(i) = sa*sx(i) 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m sx(i) = sa*sx(i) 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 sx(i) = sa*sx(i) sx(i + 1) = sa*sx(i + 1) sx(i + 2) = sa*sx(i + 2) sx(i + 3) = sa*sx(i + 3) sx(i + 4) = sa*sx(i + 4) 50 continue return end SHAR_EOF fi # end of overwriting check if test -f 'ssyr.f' then echo shar: will not over-write existing file "'ssyr.f'" else cat << SHAR_EOF > 'ssyr.f' SUBROUTINE SSYR ( UPLO, N, ALPHA, X, INCX, A, LDA ) * .. Scalar Arguments .. REAL ALPHA INTEGER INCX, LDA, N CHARACTER*1 UPLO * .. Array Arguments .. REAL A( LDA, * ), X( * ) * .. * * Purpose * ======= * * SSYR performs the symmetric rank 1 operation * * A := alpha*x*x' + A, * * where alpha is a real scalar, x is an n element vector and A is an * n by n symmetric matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - REAL . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the symmetric matrix and the strictly * lower triangular part of A is not referenced. On exit, the * upper triangular part of the array A is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the symmetric matrix and the strictly * upper triangular part of A is not referenced. On exit, the * lower triangular part of the array A is overwritten by the * lower triangular part of the updated matrix. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 7 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'SSYR ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR.( ALPHA.EQ.ZERO ) ) $ RETURN * * Set the start point in X if the increment is not unity. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * IF( LSAME( UPLO, 'U' ) )THEN * * Form A when A is stored in upper triangle. * IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*X( J ) DO 10, I = 1, J A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IX = KX DO 30, I = 1, J A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE END IF JX = JX + INCX 40 CONTINUE END IF ELSE * * Form A when A is stored in lower triangle. * IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*X( J ) DO 50, I = J, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IX = JX DO 70, I = J, N A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF * RETURN * * End of SSYR . * END SHAR_EOF fi # end of overwriting check if test -f 'strmv.f' then echo shar: will not over-write existing file "'strmv.f'" else cat << SHAR_EOF > 'strmv.f' SUBROUTINE STRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. REAL A( LDA, * ), X( * ) * .. * * Purpose * ======= * * STRMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, * * where x is an n element vector and A is an n by n unit, or non-unit, * upper or lower triangular matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' x := A*x. * * TRANS = 'T' or 't' x := A'*x. * * TRANS = 'C' or 'c' x := A'*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'STRMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := A*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX - INCX 80 CONTINUE END IF END IF ELSE * * Form x := A'*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = N, 1, -1 TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE X( J ) = TEMP 100 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 120, J = N, 1, -1 TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 110, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 110 CONTINUE X( JX ) = TEMP JX = JX - INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = 1, N TEMP = X( J ) IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 130, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 130 CONTINUE X( J ) = TEMP 140 CONTINUE ELSE JX = KX DO 160, J = 1, N TEMP = X( JX ) IX = JX IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 150 CONTINUE X( JX ) = TEMP JX = JX + INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of STRMV . * END SHAR_EOF fi # end of overwriting check if test -f 'strsv.f' then echo shar: will not over-write existing file "'strsv.f'" else cat << SHAR_EOF > 'strsv.f' SUBROUTINE STRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. REAL A( LDA, * ), X( * ) * .. * * Purpose * ======= * * STRSV solves one of the systems of equations * * A*x = b, or A'*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' A'*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - REAL array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - REAL array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0E+0 ) * .. Local Scalars .. REAL TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'STRSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOUNIT = LSAME( DIAG, 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 100, J = 1, N TEMP = X( J ) DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( J ) = TEMP 100 CONTINUE ELSE JX = KX DO 120, J = 1, N TEMP = X( JX ) IX = KX DO 110, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 110 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX + INCX 120 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 140, J = N, 1, -1 TEMP = X( J ) DO 130, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( J ) = TEMP 140 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 160, J = N, 1, -1 TEMP = X( JX ) IX = KX DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) X( JX ) = TEMP JX = JX - INCX 160 CONTINUE END IF END IF END IF * RETURN * * End of STRSV . * END SHAR_EOF fi # end of overwriting check if test -f 'xerbla.f' then echo shar: will not over-write existing file "'xerbla.f'" else cat << SHAR_EOF > 'xerbla.f' SUBROUTINE XERBLA( SRNAME, INFO ) * * -- LAPACK auxiliary routine (preliminary version) -- * Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., * Courant Institute, Argonne National Lab, and Rice University * February 29, 1992 * * .. Scalar Arguments .. CHARACTER*6 SRNAME INTEGER INFO * .. * * Purpose * ======= * * XERBLA is an error handler for the LAPACK routines. * It is called by an LAPACK routine if an input parameter has an * invalid value. A message is printed and execution stops. * * Installers may consider modifying the STOP statement in order to * call system-specific exception-handling facilities. * * Arguments * ========= * * SRNAME (input) CHARACTER*6 * The name of the routine which called XERBLA. * * INFO (input) INTEGER * The position of the invalid parameter in the parameter list * of the calling routine. * * WRITE( *, FMT = 9999 )SRNAME, INFO * STOP * 9999 FORMAT( ' ** On entry to ', A6, ' parameter number ', I2, ' had ', $ 'an illegal value' ) * * End of XERBLA * END SHAR_EOF fi # end of overwriting check if test -f 'zaxpy.f' then echo shar: will not over-write existing file "'zaxpy.f'" else cat << SHAR_EOF > 'zaxpy.f' subroutine zaxpy(n,za,zx,incx,zy,incy) c c constant times a vector plus a vector. c jack dongarra, 3/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*),zy(*),za integer i,incx,incy,ix,iy,n double precision dcabs1 if(n.le.0)return if (dcabs1(za) .eq. 0.0d0) return if (incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n zy(iy) = zy(iy) + za*zx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n zy(i) = zy(i) + za*zx(i) 30 continue return end SHAR_EOF fi # end of overwriting check if test -f 'zcopy.f' then echo shar: will not over-write existing file "'zcopy.f'" else cat << SHAR_EOF > 'zcopy.f' subroutine zcopy(n,zx,incx,zy,incy) c c copies a vector, x, to a vector, y. c jack dongarra, linpack, 4/11/78. c modified 12/3/93, array(1) declarations changed to array(*) c double complex zx(*),zy(*) integer i,incx,incy,ix,iy,n c if(n.le.0)return if(incx.eq.1.and.incy.eq.1)go to 20 c c code for unequal increments or equal increments c not equal to 1 c ix = 1 iy = 1 if(incx.lt.0)ix = (-n+1)*incx + 1 if(incy.lt.0)iy = (-n+1)*incy + 1 do 10 i = 1,n zy(iy) = zx(ix) ix = ix + incx iy = iy + incy 10 continue return c c code for both increments equal to 1 c 20 do 30 i = 1,n zy(i) = zx(i) 30 continue return end SHAR_EOF fi # end of overwriting check if test -f 'zgemm.f' then echo shar: will not over-write existing file "'zgemm.f'" else cat << SHAR_EOF > 'zgemm.f' SUBROUTINE ZGEMM ( TRANSA, TRANSB, M, N, K, ALPHA, A, LDA, B, LDB, $ BETA, C, LDC ) * .. Scalar Arguments .. CHARACTER*1 TRANSA, TRANSB INTEGER M, N, K, LDA, LDB, LDC COMPLEX*16 ALPHA, BETA * .. Array Arguments .. COMPLEX*16 A( LDA, * ), B( LDB, * ), C( LDC, * ) * .. * * Purpose * ======= * * ZGEMM performs one of the matrix-matrix operations * * C := alpha*op( A )*op( B ) + beta*C, * * where op( X ) is one of * * op( X ) = X or op( X ) = X' or op( X ) = conjg( X' ), * * alpha and beta are scalars, and A, B and C are matrices, with op( A ) * an m by k matrix, op( B ) a k by n matrix and C an m by n matrix. * * Parameters * ========== * * TRANSA - CHARACTER*1. * On entry, TRANSA specifies the form of op( A ) to be used in * the matrix multiplication as follows: * * TRANSA = 'N' or 'n', op( A ) = A. * * TRANSA = 'T' or 't', op( A ) = A'. * * TRANSA = 'C' or 'c', op( A ) = conjg( A' ). * * Unchanged on exit. * * TRANSB - CHARACTER*1. * On entry, TRANSB specifies the form of op( B ) to be used in * the matrix multiplication as follows: * * TRANSB = 'N' or 'n', op( B ) = B. * * TRANSB = 'T' or 't', op( B ) = B'. * * TRANSB = 'C' or 'c', op( B ) = conjg( B' ). * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix * op( A ) and of the matrix C. M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix * op( B ) and the number of columns of the matrix C. N must be * at least zero. * Unchanged on exit. * * K - INTEGER. * On entry, K specifies the number of columns of the matrix * op( A ) and the number of rows of the matrix op( B ). K must * be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is * k when TRANSA = 'N' or 'n', and is m otherwise. * Before entry with TRANSA = 'N' or 'n', the leading m by k * part of the array A must contain the matrix A, otherwise * the leading k by m part of the array A must contain the * matrix A. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. When TRANSA = 'N' or 'n' then * LDA must be at least max( 1, m ), otherwise LDA must be at * least max( 1, k ). * Unchanged on exit. * * B - COMPLEX*16 array of DIMENSION ( LDB, kb ), where kb is * n when TRANSB = 'N' or 'n', and is k otherwise. * Before entry with TRANSB = 'N' or 'n', the leading k by n * part of the array B must contain the matrix B, otherwise * the leading n by k part of the array B must contain the * matrix B. * Unchanged on exit. * * LDB - INTEGER. * On entry, LDB specifies the first dimension of B as declared * in the calling (sub) program. When TRANSB = 'N' or 'n' then * LDB must be at least max( 1, k ), otherwise LDB must be at * least max( 1, n ). * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then C need not be set on input. * Unchanged on exit. * * C - COMPLEX*16 array of DIMENSION ( LDC, n ). * Before entry, the leading m by n part of the array C must * contain the matrix C, except when beta is zero, in which * case C need not be set on entry. * On exit, the array C is overwritten by the m by n matrix * ( alpha*op( A )*op( B ) + beta*C ). * * LDC - INTEGER. * On entry, LDC specifies the first dimension of C as declared * in the calling (sub) program. LDC must be at least * max( 1, m ). * Unchanged on exit. * * * Level 3 Blas routine. * * -- Written on 8-February-1989. * Jack Dongarra, Argonne National Laboratory. * Iain Duff, AERE Harwell. * Jeremy Du Croz, Numerical Algorithms Group Ltd. * Sven Hammarling, Numerical Algorithms Group Ltd. * * * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. Local Scalars .. LOGICAL CONJA, CONJB, NOTA, NOTB INTEGER I, INFO, J, L, NCOLA, NROWA, NROWB COMPLEX*16 TEMP * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. * .. Executable Statements .. * * Set NOTA and NOTB as true if A and B respectively are not * conjugated or transposed, set CONJA and CONJB as true if A and * B respectively are to be transposed but not conjugated and set * NROWA, NCOLA and NROWB as the number of rows and columns of A * and the number of rows of B respectively. * NOTA = LSAME( TRANSA, 'N' ) NOTB = LSAME( TRANSB, 'N' ) CONJA = LSAME( TRANSA, 'C' ) CONJB = LSAME( TRANSB, 'C' ) IF( NOTA )THEN NROWA = M NCOLA = K ELSE NROWA = K NCOLA = M END IF IF( NOTB )THEN NROWB = K ELSE NROWB = N END IF * * Test the input parameters. * INFO = 0 IF( ( .NOT.NOTA ).AND. $ ( .NOT.CONJA ).AND. $ ( .NOT.LSAME( TRANSA, 'T' ) ) )THEN INFO = 1 ELSE IF( ( .NOT.NOTB ).AND. $ ( .NOT.CONJB ).AND. $ ( .NOT.LSAME( TRANSB, 'T' ) ) )THEN INFO = 2 ELSE IF( M .LT.0 )THEN INFO = 3 ELSE IF( N .LT.0 )THEN INFO = 4 ELSE IF( K .LT.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, NROWA ) )THEN INFO = 8 ELSE IF( LDB.LT.MAX( 1, NROWB ) )THEN INFO = 10 ELSE IF( LDC.LT.MAX( 1, M ) )THEN INFO = 13 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGEMM ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ( ALPHA.EQ.ZERO ).OR.( K.EQ.0 ) ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * * And when alpha.eq.zero. * IF( ALPHA.EQ.ZERO )THEN IF( BETA.EQ.ZERO )THEN DO 20, J = 1, N DO 10, I = 1, M C( I, J ) = ZERO 10 CONTINUE 20 CONTINUE ELSE DO 40, J = 1, N DO 30, I = 1, M C( I, J ) = BETA*C( I, J ) 30 CONTINUE 40 CONTINUE END IF RETURN END IF * * Start the operations. * IF( NOTB )THEN IF( NOTA )THEN * * Form C := alpha*A*B + beta*C. * DO 90, J = 1, N IF( BETA.EQ.ZERO )THEN DO 50, I = 1, M C( I, J ) = ZERO 50 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 60, I = 1, M C( I, J ) = BETA*C( I, J ) 60 CONTINUE END IF DO 80, L = 1, K IF( B( L, J ).NE.ZERO )THEN TEMP = ALPHA*B( L, J ) DO 70, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 70 CONTINUE END IF 80 CONTINUE 90 CONTINUE ELSE IF( CONJA )THEN * * Form C := alpha*conjg( A' )*B + beta*C. * DO 120, J = 1, N DO 110, I = 1, M TEMP = ZERO DO 100, L = 1, K TEMP = TEMP + DCONJG( A( L, I ) )*B( L, J ) 100 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 110 CONTINUE 120 CONTINUE ELSE * * Form C := alpha*A'*B + beta*C * DO 150, J = 1, N DO 140, I = 1, M TEMP = ZERO DO 130, L = 1, K TEMP = TEMP + A( L, I )*B( L, J ) 130 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 140 CONTINUE 150 CONTINUE END IF ELSE IF( NOTA )THEN IF( CONJB )THEN * * Form C := alpha*A*conjg( B' ) + beta*C. * DO 200, J = 1, N IF( BETA.EQ.ZERO )THEN DO 160, I = 1, M C( I, J ) = ZERO 160 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 170, I = 1, M C( I, J ) = BETA*C( I, J ) 170 CONTINUE END IF DO 190, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( B( J, L ) ) DO 180, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 180 CONTINUE END IF 190 CONTINUE 200 CONTINUE ELSE * * Form C := alpha*A*B' + beta*C * DO 250, J = 1, N IF( BETA.EQ.ZERO )THEN DO 210, I = 1, M C( I, J ) = ZERO 210 CONTINUE ELSE IF( BETA.NE.ONE )THEN DO 220, I = 1, M C( I, J ) = BETA*C( I, J ) 220 CONTINUE END IF DO 240, L = 1, K IF( B( J, L ).NE.ZERO )THEN TEMP = ALPHA*B( J, L ) DO 230, I = 1, M C( I, J ) = C( I, J ) + TEMP*A( I, L ) 230 CONTINUE END IF 240 CONTINUE 250 CONTINUE END IF ELSE IF( CONJA )THEN IF( CONJB )THEN * * Form C := alpha*conjg( A' )*conjg( B' ) + beta*C. * DO 280, J = 1, N DO 270, I = 1, M TEMP = ZERO DO 260, L = 1, K TEMP = TEMP + $ DCONJG( A( L, I ) )*DCONJG( B( J, L ) ) 260 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 270 CONTINUE 280 CONTINUE ELSE * * Form C := alpha*conjg( A' )*B' + beta*C * DO 310, J = 1, N DO 300, I = 1, M TEMP = ZERO DO 290, L = 1, K TEMP = TEMP + DCONJG( A( L, I ) )*B( J, L ) 290 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 300 CONTINUE 310 CONTINUE END IF ELSE IF( CONJB )THEN * * Form C := alpha*A'*conjg( B' ) + beta*C * DO 340, J = 1, N DO 330, I = 1, M TEMP = ZERO DO 320, L = 1, K TEMP = TEMP + A( L, I )*DCONJG( B( J, L ) ) 320 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 330 CONTINUE 340 CONTINUE ELSE * * Form C := alpha*A'*B' + beta*C * DO 370, J = 1, N DO 360, I = 1, M TEMP = ZERO DO 350, L = 1, K TEMP = TEMP + A( L, I )*B( J, L ) 350 CONTINUE IF( BETA.EQ.ZERO )THEN C( I, J ) = ALPHA*TEMP ELSE C( I, J ) = ALPHA*TEMP + BETA*C( I, J ) END IF 360 CONTINUE 370 CONTINUE END IF END IF * RETURN * * End of ZGEMM . * END SHAR_EOF fi # end of overwriting check if test -f 'zgemv.f' then echo shar: will not over-write existing file "'zgemv.f'" else cat << SHAR_EOF > 'zgemv.f' SUBROUTINE ZGEMV ( TRANS, M, N, ALPHA, A, LDA, X, INCX, $ BETA, Y, INCY ) * .. Scalar Arguments .. COMPLEX*16 ALPHA, BETA INTEGER INCX, INCY, LDA, M, N CHARACTER*1 TRANS * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ), Y( * ) * .. * * Purpose * ======= * * ZGEMV performs one of the matrix-vector operations * * y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y, or * * y := alpha*conjg( A' )*x + beta*y, * * where alpha and beta are scalars, x and y are vectors and A is an * m by n matrix. * * Parameters * ========== * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' y := alpha*A*x + beta*y. * * TRANS = 'T' or 't' y := alpha*A'*x + beta*y. * * TRANS = 'C' or 'c' y := alpha*conjg( A' )*x + beta*y. * * Unchanged on exit. * * M - INTEGER. * On entry, M specifies the number of rows of the matrix A. * M must be at least zero. * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the number of columns of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - COMPLEX*16 . * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry, the leading m by n part of the array A must * contain the matrix of coefficients. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, m ). * Unchanged on exit. * * X - COMPLEX*16 array of DIMENSION at least * ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. * Before entry, the incremented array X must contain the * vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * BETA - COMPLEX*16 . * On entry, BETA specifies the scalar beta. When BETA is * supplied as zero then Y need not be set on input. * Unchanged on exit. * * Y - COMPLEX*16 array of DIMENSION at least * ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' * and at least * ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. * Before entry with BETA non-zero, the incremented array Y * must contain the vector y. On exit, Y is overwritten by the * updated vector y. * * INCY - INTEGER. * On entry, INCY specifies the increment for the elements of * Y. INCY must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ONE PARAMETER ( ONE = ( 1.0D+0, 0.0D+0 ) ) COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, IY, J, JX, JY, KX, KY, LENX, LENY LOGICAL NOCONJ * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 1 ELSE IF( M.LT.0 )THEN INFO = 2 ELSE IF( N.LT.0 )THEN INFO = 3 ELSE IF( LDA.LT.MAX( 1, M ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 ELSE IF( INCY.EQ.0 )THEN INFO = 11 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZGEMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( M.EQ.0 ).OR.( N.EQ.0 ).OR. $ ( ( ALPHA.EQ.ZERO ).AND.( BETA.EQ.ONE ) ) ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) * * Set LENX and LENY, the lengths of the vectors x and y, and set * up the start points in X and Y. * IF( LSAME( TRANS, 'N' ) )THEN LENX = N LENY = M ELSE LENX = M LENY = N END IF IF( INCX.GT.0 )THEN KX = 1 ELSE KX = 1 - ( LENX - 1 )*INCX END IF IF( INCY.GT.0 )THEN KY = 1 ELSE KY = 1 - ( LENY - 1 )*INCY END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * * First form y := beta*y. * IF( BETA.NE.ONE )THEN IF( INCY.EQ.1 )THEN IF( BETA.EQ.ZERO )THEN DO 10, I = 1, LENY Y( I ) = ZERO 10 CONTINUE ELSE DO 20, I = 1, LENY Y( I ) = BETA*Y( I ) 20 CONTINUE END IF ELSE IY = KY IF( BETA.EQ.ZERO )THEN DO 30, I = 1, LENY Y( IY ) = ZERO IY = IY + INCY 30 CONTINUE ELSE DO 40, I = 1, LENY Y( IY ) = BETA*Y( IY ) IY = IY + INCY 40 CONTINUE END IF END IF END IF IF( ALPHA.EQ.ZERO ) $ RETURN IF( LSAME( TRANS, 'N' ) )THEN * * Form y := alpha*A*x + y. * JX = KX IF( INCY.EQ.1 )THEN DO 60, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) DO 50, I = 1, M Y( I ) = Y( I ) + TEMP*A( I, J ) 50 CONTINUE END IF JX = JX + INCX 60 CONTINUE ELSE DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*X( JX ) IY = KY DO 70, I = 1, M Y( IY ) = Y( IY ) + TEMP*A( I, J ) IY = IY + INCY 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF ELSE * * Form y := alpha*A'*x + y or y := alpha*conjg( A' )*x + y. * JY = KY IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = ZERO IF( NOCONJ )THEN DO 90, I = 1, M TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE DO 100, I = 1, M TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) 100 CONTINUE END IF Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 110 CONTINUE ELSE DO 140, J = 1, N TEMP = ZERO IX = KX IF( NOCONJ )THEN DO 120, I = 1, M TEMP = TEMP + A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE ELSE DO 130, I = 1, M TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE END IF Y( JY ) = Y( JY ) + ALPHA*TEMP JY = JY + INCY 140 CONTINUE END IF END IF * RETURN * * End of ZGEMV . * END SHAR_EOF fi # end of overwriting check if test -f 'zher.f' then echo shar: will not over-write existing file "'zher.f'" else cat << SHAR_EOF > 'zher.f' SUBROUTINE ZHER ( UPLO, N, ALPHA, X, INCX, A, LDA ) * .. Scalar Arguments .. DOUBLE PRECISION ALPHA INTEGER INCX, LDA, N CHARACTER*1 UPLO * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZHER performs the hermitian rank 1 operation * * A := alpha*x*conjg( x' ) + A, * * where alpha is a real scalar, x is an n element vector and A is an * n by n hermitian matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the upper or lower * triangular part of the array A is to be referenced as * follows: * * UPLO = 'U' or 'u' Only the upper triangular part of A * is to be referenced. * * UPLO = 'L' or 'l' Only the lower triangular part of A * is to be referenced. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * ALPHA - DOUBLE PRECISION. * On entry, ALPHA specifies the scalar alpha. * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. * Unchanged on exit. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular part of the hermitian matrix and the strictly * lower triangular part of A is not referenced. On exit, the * upper triangular part of the array A is overwritten by the * upper triangular part of the updated matrix. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular part of the hermitian matrix and the strictly * upper triangular part of A is not referenced. On exit, the * lower triangular part of the array A is overwritten by the * lower triangular part of the updated matrix. * Note that the imaginary parts of the diagonal elements need * not be set, they are assumed to be zero, and on exit they * are set to zero. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JX, KX * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX, DBLE * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO, 'U' ).AND. $ .NOT.LSAME( UPLO, 'L' ) )THEN INFO = 1 ELSE IF( N.LT.0 )THEN INFO = 2 ELSE IF( INCX.EQ.0 )THEN INFO = 5 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 7 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZHER ', INFO ) RETURN END IF * * Quick return if possible. * IF( ( N.EQ.0 ).OR.( ALPHA.EQ.DBLE( ZERO ) ) ) $ RETURN * * Set the start point in X if the increment is not unity. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through the triangular part * of A. * IF( LSAME( UPLO, 'U' ) )THEN * * Form A when A is stored in upper triangle. * IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( X( J ) ) DO 10, I = 1, J - 1 A( I, J ) = A( I, J ) + X( I )*TEMP 10 CONTINUE A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( J )*TEMP ) ELSE A( J, J ) = DBLE( A( J, J ) ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( X( JX ) ) IX = KX DO 30, I = 1, J - 1 A( I, J ) = A( I, J ) + X( IX )*TEMP IX = IX + INCX 30 CONTINUE A( J, J ) = DBLE( A( J, J ) ) + DBLE( X( JX )*TEMP ) ELSE A( J, J ) = DBLE( A( J, J ) ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE * * Form A when A is stored in lower triangle. * IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( X( J ) ) A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( J ) ) DO 50, I = J + 1, N A( I, J ) = A( I, J ) + X( I )*TEMP 50 CONTINUE ELSE A( J, J ) = DBLE( A( J, J ) ) END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = ALPHA*DCONJG( X( JX ) ) A( J, J ) = DBLE( A( J, J ) ) + DBLE( TEMP*X( JX ) ) IX = JX DO 70, I = J + 1, N IX = IX + INCX A( I, J ) = A( I, J ) + X( IX )*TEMP 70 CONTINUE ELSE A( J, J ) = DBLE( A( J, J ) ) END IF JX = JX + INCX 80 CONTINUE END IF END IF * RETURN * * End of ZHER . * END SHAR_EOF fi # end of overwriting check if test -f 'zscal.f' then echo shar: will not over-write existing file "'zscal.f'" else cat << SHAR_EOF > 'zscal.f' subroutine zscal(n,za,zx,incx) c c scales a vector by a constant. c jack dongarra, 3/11/78. c modified 3/93 to return if incx .le. 0. c modified 12/3/93, array(1) declarations changed to array(*) c double complex za,zx(*) integer i,incx,ix,n c if( n.le.0 .or. incx.le.0 )return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c ix = 1 do 10 i = 1,n zx(ix) = za*zx(ix) ix = ix + incx 10 continue return c c code for increment equal to 1 c 20 do 30 i = 1,n zx(i) = za*zx(i) 30 continue return end SHAR_EOF fi # end of overwriting check if test -f 'ztrmv.f' then echo shar: will not over-write existing file "'ztrmv.f'" else cat << SHAR_EOF > 'ztrmv.f' SUBROUTINE ZTRMV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZTRMV performs one of the matrix-vector operations * * x := A*x, or x := A'*x, or x := conjg( A' )*x, * * where x is an n element vector and A is an n by n unit, or non-unit, * upper or lower triangular matrix. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the operation to be performed as * follows: * * TRANS = 'N' or 'n' x := A*x. * * TRANS = 'T' or 't' x := A'*x. * * TRANS = 'C' or 'c' x := conjg( A' )*x. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element vector x. On exit, X is overwritten with the * tranformed vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOCONJ, NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTRMV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := A*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = 1, N IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 10, I = 1, J - 1 X( I ) = X( I ) + TEMP*A( I, J ) 10 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 20 CONTINUE ELSE JX = KX DO 40, J = 1, N IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 30, I = 1, J - 1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX + INCX 30 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX + INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN TEMP = X( J ) DO 50, I = N, J + 1, -1 X( I ) = X( I ) + TEMP*A( I, J ) 50 CONTINUE IF( NOUNIT ) $ X( J ) = X( J )*A( J, J ) END IF 60 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 80, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN TEMP = X( JX ) IX = KX DO 70, I = N, J + 1, -1 X( IX ) = X( IX ) + TEMP*A( I, J ) IX = IX - INCX 70 CONTINUE IF( NOUNIT ) $ X( JX ) = X( JX )*A( J, J ) END IF JX = JX - INCX 80 CONTINUE END IF END IF ELSE * * Form x := A'*x or x := conjg( A' )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 110, J = N, 1, -1 TEMP = X( J ) IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 90, I = J - 1, 1, -1 TEMP = TEMP + A( I, J )*X( I ) 90 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*DCONJG( A( J, J ) ) DO 100, I = J - 1, 1, -1 TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) 100 CONTINUE END IF X( J ) = TEMP 110 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 140, J = N, 1, -1 TEMP = X( JX ) IX = JX IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 120, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + A( I, J )*X( IX ) 120 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*DCONJG( A( J, J ) ) DO 130, I = J - 1, 1, -1 IX = IX - INCX TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) 130 CONTINUE END IF X( JX ) = TEMP JX = JX - INCX 140 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 170, J = 1, N TEMP = X( J ) IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 150, I = J + 1, N TEMP = TEMP + A( I, J )*X( I ) 150 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*DCONJG( A( J, J ) ) DO 160, I = J + 1, N TEMP = TEMP + DCONJG( A( I, J ) )*X( I ) 160 CONTINUE END IF X( J ) = TEMP 170 CONTINUE ELSE JX = KX DO 200, J = 1, N TEMP = X( JX ) IX = JX IF( NOCONJ )THEN IF( NOUNIT ) $ TEMP = TEMP*A( J, J ) DO 180, I = J + 1, N IX = IX + INCX TEMP = TEMP + A( I, J )*X( IX ) 180 CONTINUE ELSE IF( NOUNIT ) $ TEMP = TEMP*DCONJG( A( J, J ) ) DO 190, I = J + 1, N IX = IX + INCX TEMP = TEMP + DCONJG( A( I, J ) )*X( IX ) 190 CONTINUE END IF X( JX ) = TEMP JX = JX + INCX 200 CONTINUE END IF END IF END IF * RETURN * * End of ZTRMV . * END SHAR_EOF fi # end of overwriting check if test -f 'ztrsv.f' then echo shar: will not over-write existing file "'ztrsv.f'" else cat << SHAR_EOF > 'ztrsv.f' SUBROUTINE ZTRSV ( UPLO, TRANS, DIAG, N, A, LDA, X, INCX ) * .. Scalar Arguments .. INTEGER INCX, LDA, N CHARACTER*1 DIAG, TRANS, UPLO * .. Array Arguments .. COMPLEX*16 A( LDA, * ), X( * ) * .. * * Purpose * ======= * * ZTRSV solves one of the systems of equations * * A*x = b, or A'*x = b, or conjg( A' )*x = b, * * where b and x are n element vectors and A is an n by n unit, or * non-unit, upper or lower triangular matrix. * * No test for singularity or near-singularity is included in this * routine. Such tests must be performed before calling this routine. * * Parameters * ========== * * UPLO - CHARACTER*1. * On entry, UPLO specifies whether the matrix is an upper or * lower triangular matrix as follows: * * UPLO = 'U' or 'u' A is an upper triangular matrix. * * UPLO = 'L' or 'l' A is a lower triangular matrix. * * Unchanged on exit. * * TRANS - CHARACTER*1. * On entry, TRANS specifies the equations to be solved as * follows: * * TRANS = 'N' or 'n' A*x = b. * * TRANS = 'T' or 't' A'*x = b. * * TRANS = 'C' or 'c' conjg( A' )*x = b. * * Unchanged on exit. * * DIAG - CHARACTER*1. * On entry, DIAG specifies whether or not A is unit * triangular as follows: * * DIAG = 'U' or 'u' A is assumed to be unit triangular. * * DIAG = 'N' or 'n' A is not assumed to be unit * triangular. * * Unchanged on exit. * * N - INTEGER. * On entry, N specifies the order of the matrix A. * N must be at least zero. * Unchanged on exit. * * A - COMPLEX*16 array of DIMENSION ( LDA, n ). * Before entry with UPLO = 'U' or 'u', the leading n by n * upper triangular part of the array A must contain the upper * triangular matrix and the strictly lower triangular part of * A is not referenced. * Before entry with UPLO = 'L' or 'l', the leading n by n * lower triangular part of the array A must contain the lower * triangular matrix and the strictly upper triangular part of * A is not referenced. * Note that when DIAG = 'U' or 'u', the diagonal elements of * A are not referenced either, but are assumed to be unity. * Unchanged on exit. * * LDA - INTEGER. * On entry, LDA specifies the first dimension of A as declared * in the calling (sub) program. LDA must be at least * max( 1, n ). * Unchanged on exit. * * X - COMPLEX*16 array of dimension at least * ( 1 + ( n - 1 )*abs( INCX ) ). * Before entry, the incremented array X must contain the n * element right-hand side vector b. On exit, X is overwritten * with the solution vector x. * * INCX - INTEGER. * On entry, INCX specifies the increment for the elements of * X. INCX must not be zero. * Unchanged on exit. * * * Level 2 Blas routine. * * -- Written on 22-October-1986. * Jack Dongarra, Argonne National Lab. * Jeremy Du Croz, Nag Central Office. * Sven Hammarling, Nag Central Office. * Richard Hanson, Sandia National Labs. * * * .. Parameters .. COMPLEX*16 ZERO PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ) ) * .. Local Scalars .. COMPLEX*16 TEMP INTEGER I, INFO, IX, J, JX, KX LOGICAL NOCONJ, NOUNIT * .. External Functions .. LOGICAL LSAME EXTERNAL LSAME * .. External Subroutines .. EXTERNAL XERBLA * .. Intrinsic Functions .. INTRINSIC DCONJG, MAX * .. * .. Executable Statements .. * * Test the input parameters. * INFO = 0 IF ( .NOT.LSAME( UPLO , 'U' ).AND. $ .NOT.LSAME( UPLO , 'L' ) )THEN INFO = 1 ELSE IF( .NOT.LSAME( TRANS, 'N' ).AND. $ .NOT.LSAME( TRANS, 'T' ).AND. $ .NOT.LSAME( TRANS, 'C' ) )THEN INFO = 2 ELSE IF( .NOT.LSAME( DIAG , 'U' ).AND. $ .NOT.LSAME( DIAG , 'N' ) )THEN INFO = 3 ELSE IF( N.LT.0 )THEN INFO = 4 ELSE IF( LDA.LT.MAX( 1, N ) )THEN INFO = 6 ELSE IF( INCX.EQ.0 )THEN INFO = 8 END IF IF( INFO.NE.0 )THEN CALL XERBLA( 'ZTRSV ', INFO ) RETURN END IF * * Quick return if possible. * IF( N.EQ.0 ) $ RETURN * NOCONJ = LSAME( TRANS, 'T' ) NOUNIT = LSAME( DIAG , 'N' ) * * Set up the start point in X if the increment is not unity. This * will be ( N - 1 )*INCX too small for descending loops. * IF( INCX.LE.0 )THEN KX = 1 - ( N - 1 )*INCX ELSE IF( INCX.NE.1 )THEN KX = 1 END IF * * Start the operations. In this version the elements of A are * accessed sequentially with one pass through A. * IF( LSAME( TRANS, 'N' ) )THEN * * Form x := inv( A )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 20, J = N, 1, -1 IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 10, I = J - 1, 1, -1 X( I ) = X( I ) - TEMP*A( I, J ) 10 CONTINUE END IF 20 CONTINUE ELSE JX = KX + ( N - 1 )*INCX DO 40, J = N, 1, -1 IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 30, I = J - 1, 1, -1 IX = IX - INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 30 CONTINUE END IF JX = JX - INCX 40 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 60, J = 1, N IF( X( J ).NE.ZERO )THEN IF( NOUNIT ) $ X( J ) = X( J )/A( J, J ) TEMP = X( J ) DO 50, I = J + 1, N X( I ) = X( I ) - TEMP*A( I, J ) 50 CONTINUE END IF 60 CONTINUE ELSE JX = KX DO 80, J = 1, N IF( X( JX ).NE.ZERO )THEN IF( NOUNIT ) $ X( JX ) = X( JX )/A( J, J ) TEMP = X( JX ) IX = JX DO 70, I = J + 1, N IX = IX + INCX X( IX ) = X( IX ) - TEMP*A( I, J ) 70 CONTINUE END IF JX = JX + INCX 80 CONTINUE END IF END IF ELSE * * Form x := inv( A' )*x or x := inv( conjg( A' ) )*x. * IF( LSAME( UPLO, 'U' ) )THEN IF( INCX.EQ.1 )THEN DO 110, J = 1, N TEMP = X( J ) IF( NOCONJ )THEN DO 90, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( I ) 90 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 100, I = 1, J - 1 TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) 100 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( J ) = TEMP 110 CONTINUE ELSE JX = KX DO 140, J = 1, N IX = KX TEMP = X( JX ) IF( NOCONJ )THEN DO 120, I = 1, J - 1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX + INCX 120 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 130, I = 1, J - 1 TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) IX = IX + INCX 130 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( JX ) = TEMP JX = JX + INCX 140 CONTINUE END IF ELSE IF( INCX.EQ.1 )THEN DO 170, J = N, 1, -1 TEMP = X( J ) IF( NOCONJ )THEN DO 150, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( I ) 150 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 160, I = N, J + 1, -1 TEMP = TEMP - DCONJG( A( I, J ) )*X( I ) 160 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( J ) = TEMP 170 CONTINUE ELSE KX = KX + ( N - 1 )*INCX JX = KX DO 200, J = N, 1, -1 IX = KX TEMP = X( JX ) IF( NOCONJ )THEN DO 180, I = N, J + 1, -1 TEMP = TEMP - A( I, J )*X( IX ) IX = IX - INCX 180 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/A( J, J ) ELSE DO 190, I = N, J + 1, -1 TEMP = TEMP - DCONJG( A( I, J ) )*X( IX ) IX = IX - INCX 190 CONTINUE IF( NOUNIT ) $ TEMP = TEMP/DCONJG( A( J, J ) ) END IF X( JX ) = TEMP JX = JX - INCX 200 CONTINUE END IF END IF END IF * RETURN * * End of ZTRSV . * END SHAR_EOF fi # end of overwriting check cd .. if test -f 'make.inc' then echo shar: will not over-write existing file "'make.inc'" else cat << SHAR_EOF > 'make.inc' ########################################################################## # # Modify the FORTRAN and _OPT definitions to refer to the compiler # and desired compiler options for your machine. Define LOADER and # LOADOPTS to refer to the loader and desired load options for your # machine. The compiler options are specified as follows for the # different programs and libraries: # # GBL3BOPT : the GEMM-based level 3 BLAS routines # GBBENOPT : the GEMM-based performance benchmark programs # TSTOPT : the test programs for correctness tests # UNDEROPT : the underlying BLAS routines # TMGOPT : the timing routines # AUXOPT : various auxiliary routines # FORTRAN = f77 GBL3BOPT = -O2 GBBENOPT = -O2 TSTOPT = -O2 UNDEROPT = -O2 TMGOPT = -O2 AUXOPT = -O2 LOADER = f77 LOADOPT = # # The archiver and the flag(s) to use when building archive (library) # If you system has no ranlib, set RANLIB = echo. # ARCH = ar ARCHFLAGS = cr RANLIB = ranlib # # Libraries to be created. If the libraries are not specified, the # libraries are not created. The libraries are specified relative # to the subdirectories where they are produced. # # CREGBLIB : the GEMM-based level 3 BLAS library # CREULIB : a library for the underlying BLAS routines # CRETMG : a library for the timing routines # CREGBLIB = ../../libgbl3b.a CREULIB = ../libunderlib.a CRETMG = ../../libtmglib.a # # Libraries used by the testing and timing programs. # # USELIB : user specified level 3 BLAS library to be tested # and/or timed. # USEULIB : a library for the underlying BLAS routines # USETMG : a library for the timing routines # USELIB = ../../libgbl3b.a USEULIB = ../../libunderlib.a USETMG = ../../libtmglib.a SHAR_EOF fi # end of overwriting check # End of shell archive exit 0