📄 c_dblat2.f
字号:
$ CUPLO, CTRANS, CDIAG, N, INCX IF( REWI ) $ REWIND NTRA CALL CDTPMV( IORDER, UPLO, TRANS, DIAG, $ N, AA, XX, INCX ) END IF ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN IF( FULL )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9993 )NC, SNAME, $ CUPLO, CTRANS, CDIAG, N, LDA, INCX IF( REWI ) $ REWIND NTRA CALL CDTRSV( IORDER, UPLO, TRANS, DIAG, $ N, AA, LDA, XX, INCX ) ELSE IF( BANDED )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, $ CUPLO, CTRANS, CDIAG, N, K, LDA, INCX IF( REWI ) $ REWIND NTRA CALL CDTBSV( IORDER, UPLO, TRANS, DIAG, $ N, K, AA, LDA, XX, INCX ) ELSE IF( PACKED )THEN IF( TRACE ) $ WRITE( NTRA, FMT = 9995 )NC, SNAME, $ CUPLO, CTRANS, CDIAG, N, INCX IF( REWI ) $ REWIND NTRA CALL CDTPSV( IORDER, UPLO, TRANS, DIAG, $ N, AA, XX, INCX ) END IF END IF** Check if error-exit was taken incorrectly.* IF( .NOT.OK )THEN WRITE( NOUT, FMT = 9992 ) FATAL = .TRUE. GO TO 120 END IF** See what data changed inside subroutines.* ISAME( 1 ) = UPLO.EQ.UPLOS ISAME( 2 ) = TRANS.EQ.TRANSS ISAME( 3 ) = DIAG.EQ.DIAGS ISAME( 4 ) = NS.EQ.N IF( FULL )THEN ISAME( 5 ) = LDE( AS, AA, LAA ) ISAME( 6 ) = LDAS.EQ.LDA IF( NULL )THEN ISAME( 7 ) = LDE( XS, XX, LX ) ELSE ISAME( 7 ) = LDERES( 'ge', ' ', 1, N, XS, $ XX, ABS( INCX ) ) END IF ISAME( 8 ) = INCXS.EQ.INCX ELSE IF( BANDED )THEN ISAME( 5 ) = KS.EQ.K ISAME( 6 ) = LDE( AS, AA, LAA ) ISAME( 7 ) = LDAS.EQ.LDA IF( NULL )THEN ISAME( 8 ) = LDE( XS, XX, LX ) ELSE ISAME( 8 ) = LDERES( 'ge', ' ', 1, N, XS, $ XX, ABS( INCX ) ) END IF ISAME( 9 ) = INCXS.EQ.INCX ELSE IF( PACKED )THEN ISAME( 5 ) = LDE( AS, AA, LAA ) IF( NULL )THEN ISAME( 6 ) = LDE( XS, XX, LX ) ELSE ISAME( 6 ) = LDERES( 'ge', ' ', 1, N, XS, $ XX, ABS( INCX ) ) END IF ISAME( 7 ) = INCXS.EQ.INCX END IF** If data was incorrectly changed, report and* return.* SAME = .TRUE. DO 40 I = 1, NARGS SAME = SAME.AND.ISAME( I ) IF( .NOT.ISAME( I ) ) $ WRITE( NOUT, FMT = 9998 )I 40 CONTINUE IF( .NOT.SAME )THEN FATAL = .TRUE. GO TO 120 END IF* IF( .NOT.NULL )THEN IF( SNAME( 10: 11 ).EQ.'mv' )THEN** Check the result.* CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, $ INCX, ZERO, Z, INCX, XT, G, $ XX, EPS, ERR, FATAL, NOUT, $ .TRUE. ) ELSE IF( SNAME( 10: 11 ).EQ.'sv' )THEN** Compute approximation to original vector.* DO 50 I = 1, N Z( I ) = XX( 1 + ( I - 1 )* $ ABS( INCX ) ) XX( 1 + ( I - 1 )*ABS( INCX ) ) $ = X( I ) 50 CONTINUE CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z, $ INCX, ZERO, X, INCX, XT, G, $ XX, EPS, ERR, FATAL, NOUT, $ .FALSE. ) END IF ERRMAX = MAX( ERRMAX, ERR )* If got really bad answer, report and return. IF( FATAL ) $ GO TO 120 ELSE* Avoid repeating tests with N.le.0. GO TO 110 END IF* 60 CONTINUE* 70 CONTINUE* 80 CONTINUE* 90 CONTINUE* 100 CONTINUE* 110 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* 120 CONTINUE WRITE( NOUT, FMT = 9996 )SNAME IF( FULL )THEN WRITE( NOUT, FMT = 9993 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, $ LDA, INCX ELSE IF( BANDED )THEN WRITE( NOUT, FMT = 9994 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, K, $ LDA, INCX ELSE IF( PACKED )THEN WRITE( NOUT, FMT = 9995 )NC, SNAME, CUPLO, CTRANS, CDIAG, N, $ INCX END IF* 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 *******' ) 9997 FORMAT( ' ',A12, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C', $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2, $ ' - SUSPECT *******' ) 9996 FORMAT( ' ******* ',A12, ' FAILED ON CALL NUMBER:' ) 9995 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', AP, ', $ 'X,', I2, ') .' ) 9994 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, 2( I3, ',' ), $ ' A,', I3, ', X,', I2, ') .' ) 9993 FORMAT( 1X, I6, ': ',A12, '(', 3( A14,',' ),/ 10x, I3, ', A,', $ I3, ', X,', I2, ') .' ) 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *', $ '******' )** End of DCHK3.* END SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI, $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX, $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G, $ Z, IORDER )** Tests DGER.** Auxiliary routine for test program for Level 2 Blas.** -- Written on 10-August-1987.* Richard Hanson, Sandia National Labs.* Jeremy Du Croz, NAG Central Office.** .. Parameters .. DOUBLE PRECISION ZERO, HALF, ONE PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )* .. Scalar Arguments .. DOUBLE PRECISION EPS, THRESH INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA, $ IORDER LOGICAL FATAL, REWI, TRACE CHARACTER*12 SNAME* .. Array Arguments .. DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ), $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ), $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ), $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ), $ YY( NMAX*INCMAX ), Z( NMAX ) INTEGER IDIM( NIDIM ), INC( NINC )* .. Local Scalars .. DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX, $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS, $ NC, ND, NS LOGICAL NULL, RESET, SAME* .. Local Arrays .. DOUBLE PRECISION W( 1 ) LOGICAL ISAME( 13 )* .. External Functions .. LOGICAL LDE, LDERES EXTERNAL LDE, LDERES* .. External Subroutines .. EXTERNAL DGER, DMAKE, DMVCH* .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN* .. Scalars in Common .. INTEGER INFOT, NOUTC LOGICAL OK* .. Common blocks .. COMMON /INFOC/INFOT, NOUTC, OK* .. Executable Statements ..* Define the number of arguments. NARGS = 9* NC = 0 RESET = .TRUE. ERRMAX = ZERO* DO 120 IN = 1, NIDIM N = IDIM( IN ) ND = N/2 + 1* DO 110 IM = 1, 2 IF( IM.EQ.1 ) $ M = MAX( N - ND, 0 ) IF( IM.EQ.2 ) $ M = MIN( N + ND, NMAX )** Set LDA to 1 more than minimum value if room. LDA = M IF( LDA.LT.NMAX ) $ LDA = LDA + 1* Skip tests if not enough room. IF( LDA.GT.NMAX ) $ GO TO 110 LAA = LDA*N NULL = N.LE.0.OR.M.LE.0* DO 100 IX = 1, NINC INCX = INC( IX ) LX = ABS( INCX )*M** Generate the vector X.* TRANSL = HALF CALL DMAKE( 'ge', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ), $ 0, M - 1, RESET, TRANSL ) IF( M.GT.1 )THEN X( M/2 ) = ZERO XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO END IF* DO 90 IY = 1, NINC INCY = INC( IY ) LY = ABS( INCY )*N** Generate the vector Y.* TRANSL = ZERO CALL DMAKE( 'ge', ' ', ' ', 1, N, Y, 1, YY, $ ABS( INCY ), 0, N - 1, RESET, TRANSL ) IF( N.GT.1 )THEN Y( N/2 ) = ZERO YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO END IF* DO 80 IA = 1, NALF ALPHA = ALF( IA )** Generate the matrix A.* TRANSL = ZERO CALL DMAKE( SNAME( 8: 9 ), ' ', ' ', M, N, A, NMAX, $ AA, LDA, M - 1, N - 1, RESET, TRANSL )* NC = NC + 1** Save every datum before calling the subroutine.* MS = M NS = N ALS = ALPHA DO 10 I = 1, LAA AS( I ) = AA( I ) 10 CONTINUE LDAS = LDA DO 20 I = 1, LX XS( I ) = XX( I ) 20 CONTINUE INCXS = INCX DO 30 I = 1, LY YS( I ) = YY( I ) 30 CONTINUE INCYS = INCY** Call the subroutine.* IF( TRACE ) $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N, $ ALPHA, INCX, INCY, LDA IF( REWI ) $ REWIND NTRA CALL CDGER( IORDER, M, N, ALPHA, XX, INCX, YY, $ INCY, AA, LDA )** Check if error-exit was take⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -