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 *