📄 c_sblat3.f
字号:
$ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX ) INTEGER IDIM( NIDIM )* .. Local Scalars .. REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS, $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA, $ NARGS, NC, NS LOGICAL NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT* .. Local Arrays .. LOGICAL ISAME( 13 )* .. External Functions .. LOGICAL LSE, LSERES EXTERNAL LSE, LSERES* .. External Subroutines .. EXTERNAL SMAKE, SMMCH, CSSYRK* .. Intrinsic Functions .. INTRINSIC MAX* .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL OK* .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK* .. Data statements .. DATA ICHT/'NTC'/, ICHU/'UL'/* .. Executable Statements ..* NARGS = 10 NC = 0 RESET = .TRUE. ERRMAX = ZERO* DO 100 IN = 1, NIDIM N = IDIM( IN )* Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ LDC = LDC + 1* Skip tests if not enough room. IF( LDC.GT.NMAX ) $ GO TO 100 LCC = LDC*N NULL = N.LE.0* DO 90 IK = 1, NIDIM K = IDIM( IK )* DO 80 ICT = 1, 3 TRANS = ICHT( ICT: ICT ) TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C' IF( TRAN )THEN MA = K NA = N ELSE MA = N NA = K END IF* Set LDA to 1 more than minimum value if room. LDA = MA IF( LDA.LT.NMAX ) $ LDA = LDA + 1* Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 80 LAA = LDA*NA** Generate the matrix A.* CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA, $ RESET, ZERO )* DO 70 ICU = 1, 2 UPLO = ICHU( ICU: ICU ) UPPER = UPLO.EQ.'U'* DO 60 IA = 1, NALF ALPHA = ALF( IA )* DO 50 IB = 1, NBET BETA = BET( IB )** Generate the matrix C.* CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC, $ LDC, RESET, ZERO )* NC = NC + 1** Save every datum before calling the subroutine.* UPLOS = UPLO TRANSS = TRANS NS = N KS = K ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA BETS = BETA DO 20 I = 1, LCC CS( I ) = CC( I ) 20 CONTINUE LDCS = LDC** Call the subroutine.* IF( TRACE ) $ CALL SPRCN4( NTRA, NC, SNAME, IORDER, UPLO, $ TRANS, N, K, ALPHA, LDA, BETA, LDC) IF( REWI ) $ REWIND NTRA CALL CSSYRK( IORDER, UPLO, TRANS, N, K, ALPHA, $ AA, LDA, BETA, CC, LDC )** Check if error-exit was taken incorrectly.* IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9993 ) FATAL = .TRUE. GO TO 120 END IF** See what data changed inside subroutines.* ISAME( 1 ) = UPLOS.EQ.UPLO ISAME( 2 ) = TRANSS.EQ.TRANS ISAME( 3 ) = NS.EQ.N ISAME( 4 ) = KS.EQ.K ISAME( 5 ) = ALS.EQ.ALPHA ISAME( 6 ) = LSE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA ISAME( 8 ) = BETS.EQ.BETA IF( NULL )THEN ISAME( 9 ) = LSE( CS, CC, LCC ) ELSE ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS, $ CC, LDC ) END IF ISAME( 10 ) = LDCS.EQ.LDC** If data was incorrectly changed, report and* return.* SAME = .TRUE. DO 30 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I+1 30 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF* IF( .NOT.NULL )THEN** Check the result column by column.* JC = 1 DO 40 J = 1, N IF( UPPER )THEN JJ = 1 LJ = J ELSE JJ = J LJ = N - J + 1 END IF IF( TRAN )THEN CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA, $ A( 1, JJ ), NMAX, $ A( 1, J ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) ELSE CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA, $ A( JJ, 1 ), NMAX, $ A( J, 1 ), NMAX, BETA, $ C( JJ, J ), NMAX, CT, G, $ CC( JC ), LDC, EPS, ERR, $ FATAL, NOUT, .TRUE. ) END IF IF( UPPER )THEN JC = JC + LDC ELSE JC = JC + LDC + 1 END IF ERRMAX = MAX( ERRMAX, ERR )* If got really bad answer, report and* return. IF( FATAL ) $ GO TO 110 40 CONTINUE END IF* 50 CONTINUE* 60 CONTINUE* 70 CONTINUE* 80 CONTINUE* 90 CONTINUE* 100 CONTINUE** Report result.* IF( ERRMAX.LT.THRESH )THEN IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10000 )SNAME, NC IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10001 )SNAME, NC ELSE IF ( IORDER.EQ.0) WRITE( NOUT, FMT = 10002 )SNAME, NC, ERRMAX IF ( IORDER.EQ.1) WRITE( NOUT, FMT = 10003 )SNAME, NC, ERRMAX END IF GO TO 130* 110 CONTINUE IF( N.GT.1 ) $ WRITE( NOUT, FMT = 9995 )J* 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME CALL SPRCN4( NOUT, NC, SNAME, IORDER, UPLO, TRANS, N, K, ALPHA, $ LDA, BETA, LDC)* 130 CONTINUE RETURN*10003 FORMAT( ' ', A12,' COMPLETED THE ROW-MAJOR COMPUTATIONAL ', $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', $ 'RATIO ', F8.2, ' - SUSPECT *******' )10002 FORMAT( ' ', A12,' COMPLETED THE COLUMN-MAJOR COMPUTATIONAL ', $ 'TESTS (', I6, ' CALLS)', /' ******* BUT WITH MAXIMUM TEST ', $ 'RATIO ', F8.2, ' - SUSPECT *******' )10001 FORMAT( ' ', A12,' PASSED THE ROW-MAJOR COMPUTATIONAL TESTS', $ ' (', I6, ' CALL', 'S)' )10000 FORMAT( ' ', A12,' PASSED THE COLUMN-MAJOR COMPUTATIONAL TESTS', $ ' (', I6, ' CALL', 'S)' ) 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH', $ 'ANGED INCORRECTLY *******' ) 9996 FORMAT( ' ******* ', A12,' FAILED ON CALL NUMBER:' ) 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 ) 9994 FORMAT( 1X, I6, ': ', A12,'(', 2( '''', A1, ''',' ), 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' ) 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' )** End of SCHK4.* END* SUBROUTINE SPRCN4(NOUT, NC, SNAME, IORDER, UPLO, TRANSA, $ N, K, ALPHA, LDA, BETA, LDC) INTEGER NOUT, NC, IORDER, N, K, LDA, LDC REAL ALPHA, BETA CHARACTER*1 UPLO, TRANSA CHARACTER*12 SNAME CHARACTER*14 CRC, CU, CA IF (UPLO.EQ.'U')THEN CU = ' CblasUpper' ELSE CU = ' CblasLower' END IF IF (TRANSA.EQ.'N')THEN CA = ' CblasNoTrans' ELSE IF (TRANSA.EQ.'T')THEN CA = ' CblasTrans' ELSE CA = 'CblasConjTrans' END IF IF (IORDER.EQ.1)THEN CRC = ' CblasRowMajor' ELSE CRC = ' CblasColMajor' END IF WRITE(NOUT, FMT = 9995)NC, SNAME, CRC, CU, CA WRITE(NOUT, FMT = 9994)N, K, ALPHA, LDA, BETA, LDC 9995 FORMAT( 1X, I6, ': ', A12,'(', 3( A14, ',') ) 9994 FORMAT( 20X, 2( I3, ',' ), $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ').' ) END* SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX, $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W, $ IORDER )** Tests SSYR2K.** Auxiliary routine for test program for Level 3 Blas.** -- Written on 8-February-1989.* Jack Dongarra, Argonne National Laboratory.* Iain Duff, AERE Harwell.* Jeremy Du Croz, Numerical Algorithms Group Ltd.* Sven Hammarling, Numerical Algorithms Group Ltd.** .. Parameters .. REAL ZERO PARAMETER ( ZERO = 0.0 )* .. Scalar Arguments .. REAL EPS, THRESH INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA, IORDER LOGICAL FATAL, REWI, TRACE CHARACTER*12 SNAME* .. Array Arguments .. REAL AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ), $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ), $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ), $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ), $ G( NMAX ), W( 2*NMAX ) INTEGER IDIM( NIDIM )* .. Local Scalars .. REAL ALPHA, ALS, BETA, BETS, ERR, ERRMAX INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB, $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS, $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS LOGICAL NULL, RESET, SAME, TRAN, UPPER CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS CHARACTER*2 ICHU CHARACTER*3 ICHT* .. Local Arrays .. LOGICAL ISAME( 13 )* .. External Functions .. LOGICAL LSE, LSERES EXTERNAL LSE, LSERES* .. External Subroutines .. EXTERNAL SMAKE, SMMCH, CSSYR2K* .. Intrinsic Functions .. INTRINSIC MAX* .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL OK* .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK* .. Data statements .. DATA ICHT/'NTC'/, ICHU/'UL'/* .. Executable Statements ..* NARGS = 12 NC = 0 RESET = .TRUE. ERRMAX = ZERO* DO 130 IN = 1, NIDIM N = IDIM( IN )* Set LDC to 1 more than minimum value if room. LDC = N IF( LDC.LT.NMAX ) $ ⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -