phynexis-deps/lapack
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Files
introduce-cpp
lapack/TESTING/LIN/dchkab.f
T
Julie e18d437924 Making LAPACK's code eternal... no more version and date in source files. 
GitHub is now enabling us to track accurately version and date.
No need for this anymore.
2021-03-25 10:16:58 -07:00

365 lines
10 KiB
FortranFixed
Raw Permalink Blame History

*> \brief \b DCHKAB
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* PROGRAM DCHKAB
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DCHKAB is the test program for the DOUBLE PRECISION LAPACK
*> DSGESV/DSPOSV routine
*>
*> The program must be driven by a short data file. The first 5 records
*> specify problem dimensions and program options using list-directed
*> input. The remaining lines specify the LAPACK test paths and the
*> number of matrix types to use in testing. An annotated example of a
*> data file can be obtained by deleting the first 3 characters from the
*> following 10 lines:
*> Data file for testing DOUBLE PRECISION LAPACK DSGESV
*> 7 Number of values of M
*> 0 1 2 3 5 10 16 Values of M (row dimension)
*> 1 Number of values of NRHS
*> 2 Values of NRHS (number of right hand sides)
*> 20.0 Threshold value of test ratio
*> T Put T to test the LAPACK routines
*> T Put T to test the error exits
*> DGE 11 List types on next line if 0 < NTYPES < 11
*> DPO 9 List types on next line if 0 < NTYPES < 9
*> \endverbatim
*
* Arguments:
* ==========
*
*> \verbatim
*> NMAX INTEGER
*> The maximum allowable value for N
*>
*> MAXIN INTEGER
*> The number of different values that can be used for each of
*> M, N, NRHS, NB, and NX
*>
*> MAXRHS INTEGER
*> The maximum number of right hand sides
*>
*> NIN INTEGER
*> The unit number for input
*>
*> NOUT INTEGER
*> The unit number for output
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup double_lin
*
* =====================================================================
PROGRAM DCHKAB
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX
PARAMETER ( NMAX = 132 )
INTEGER MAXIN
PARAMETER ( MAXIN = 12 )
INTEGER MAXRHS
PARAMETER ( MAXRHS = 16 )
INTEGER MATMAX
PARAMETER ( MATMAX = 30 )
INTEGER NIN, NOUT
PARAMETER ( NIN = 5, NOUT = 6 )
INTEGER LDAMAX
PARAMETER ( LDAMAX = NMAX )
* ..
* .. Local Scalars ..
LOGICAL FATAL, TSTDRV, TSTERR
CHARACTER C1
CHARACTER*2 C2
CHARACTER*3 PATH
CHARACTER*10 INTSTR
CHARACTER*72 ALINE
INTEGER I, IC, K, LDA, NM, NMATS,
$ NNS, NRHS, NTYPES,
$ VERS_MAJOR, VERS_MINOR, VERS_PATCH
DOUBLE PRECISION EPS, S1, S2, THRESH
REAL SEPS
* ..
* .. Local Arrays ..
LOGICAL DOTYPE( MATMAX )
INTEGER IWORK( NMAX ), MVAL( MAXIN ), NSVAL( MAXIN )
DOUBLE PRECISION A( LDAMAX*NMAX, 2 ), B( NMAX*MAXRHS, 2 ),
$ RWORK( NMAX ), WORK( NMAX*MAXRHS*2 )
REAL SWORK(NMAX*(NMAX+MAXRHS))
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DSECND
LOGICAL LSAME, LSAMEN
REAL SLAMCH
EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND, SLAMCH
* ..
* .. External Subroutines ..
EXTERNAL ALAREQ, DDRVAB, DDRVAC, DERRAB, DERRAC,
$ ILAVER
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*32 SRNAMT
INTEGER INFOT, NUNIT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NUNIT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Data statements ..
DATA INTSTR / '0123456789' /
* ..
* .. Executable Statements ..
*
S1 = DSECND( )
LDA = NMAX
FATAL = .FALSE.
*
* Read a dummy line.
*
READ( NIN, FMT = * )
*
* Report values of parameters.
*
CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
WRITE( NOUT, FMT = 9994 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH
*
* Read the values of M
*
READ( NIN, FMT = * )NM
IF( NM.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )' NM ', NM, 1
NM = 0
FATAL = .TRUE.
ELSE IF( NM.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )' NM ', NM, MAXIN
NM = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( MVAL( I ), I = 1, NM )
DO 10 I = 1, NM
IF( MVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )' M ', MVAL( I ), 0
FATAL = .TRUE.
ELSE IF( MVAL( I ).GT.NMAX ) THEN
WRITE( NOUT, FMT = 9995 )' M ', MVAL( I ), NMAX
FATAL = .TRUE.
END IF
10 CONTINUE
IF( NM.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'M ', ( MVAL( I ), I = 1, NM )
*
* Read the values of NRHS
*
READ( NIN, FMT = * )NNS
IF( NNS.LT.1 ) THEN
WRITE( NOUT, FMT = 9996 )' NNS', NNS, 1
NNS = 0
FATAL = .TRUE.
ELSE IF( NNS.GT.MAXIN ) THEN
WRITE( NOUT, FMT = 9995 )' NNS', NNS, MAXIN
NNS = 0
FATAL = .TRUE.
END IF
READ( NIN, FMT = * )( NSVAL( I ), I = 1, NNS )
DO 30 I = 1, NNS
IF( NSVAL( I ).LT.0 ) THEN
WRITE( NOUT, FMT = 9996 )'NRHS', NSVAL( I ), 0
FATAL = .TRUE.
ELSE IF( NSVAL( I ).GT.MAXRHS ) THEN
WRITE( NOUT, FMT = 9995 )'NRHS', NSVAL( I ), MAXRHS
FATAL = .TRUE.
END IF
30 CONTINUE
IF( NNS.GT.0 )
$ WRITE( NOUT, FMT = 9993 )'NRHS', ( NSVAL( I ), I = 1, NNS )
*
* Read the threshold value for the test ratios.
*
READ( NIN, FMT = * )THRESH
WRITE( NOUT, FMT = 9992 )THRESH
*
* Read the flag that indicates whether to test the driver routine.
*
READ( NIN, FMT = * )TSTDRV
*
* Read the flag that indicates whether to test the error exits.
*
READ( NIN, FMT = * )TSTERR
*
IF( FATAL ) THEN
WRITE( NOUT, FMT = 9999 )
STOP
END IF
*
* Calculate and print the machine dependent constants.
*
SEPS = SLAMCH( 'Underflow threshold' )
WRITE( NOUT, FMT = 9991 )'(single precision) underflow', SEPS
SEPS = SLAMCH( 'Overflow threshold' )
WRITE( NOUT, FMT = 9991 )'(single precision) overflow ', SEPS
SEPS = SLAMCH( 'Epsilon' )
WRITE( NOUT, FMT = 9991 )'(single precision) precision', SEPS
WRITE( NOUT, FMT = * )
*
EPS = DLAMCH( 'Underflow threshold' )
WRITE( NOUT, FMT = 9991 )'(double precision) underflow', EPS
EPS = DLAMCH( 'Overflow threshold' )
WRITE( NOUT, FMT = 9991 )'(double precision) overflow ', EPS
EPS = DLAMCH( 'Epsilon' )
WRITE( NOUT, FMT = 9991 )'(double precision) precision', EPS
WRITE( NOUT, FMT = * )
*
80 CONTINUE
*
* Read a test path and the number of matrix types to use.
*
READ( NIN, FMT = '(A72)', END = 140 )ALINE
PATH = ALINE( 1: 3 )
NMATS = MATMAX
I = 3
90 CONTINUE
I = I + 1
IF( I.GT.72 ) THEN
NMATS = MATMAX
GO TO 130
END IF
IF( ALINE( I: I ).EQ.' ' )
$ GO TO 90
NMATS = 0
100 CONTINUE
C1 = ALINE( I: I )
DO 110 K = 1, 10
IF( C1.EQ.INTSTR( K: K ) ) THEN
IC = K - 1
GO TO 120
END IF
110 CONTINUE
GO TO 130
120 CONTINUE
NMATS = NMATS*10 + IC
I = I + 1
IF( I.GT.72 )
$ GO TO 130
GO TO 100
130 CONTINUE
C1 = PATH( 1: 1 )
C2 = PATH( 2: 3 )
NRHS = NSVAL( 1 )
*
* Check first character for correct precision.
*
IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN
WRITE( NOUT, FMT = 9990 )PATH
*
ELSE IF( NMATS.LE.0 ) THEN
*
* Check for a positive number of tests requested.
*
WRITE( NOUT, FMT = 9989 )PATH
GO TO 140
*
ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
*
* GE: general matrices
*
NTYPES = 11
CALL ALAREQ( 'DGE', NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
* Test the error exits
*
IF( TSTERR )
$ CALL DERRAB( NOUT )
*
IF( TSTDRV ) THEN
CALL DDRVAB( DOTYPE, NM, MVAL, NNS,
$ NSVAL, THRESH, LDA, A( 1, 1 ),
$ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
$ WORK, RWORK, SWORK, IWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )'DSGESV'
END IF
*
ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
*
* PO: positive definite matrices
*
NTYPES = 9
CALL ALAREQ( 'DPO', NMATS, DOTYPE, NTYPES, NIN, NOUT )
*
*
IF( TSTERR )
$ CALL DERRAC( NOUT )
*
*
IF( TSTDRV ) THEN
CALL DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL,
$ THRESH, LDA, A( 1, 1 ), A( 1, 2 ),
$ B( 1, 1 ), B( 1, 2 ),
$ WORK, RWORK, SWORK, NOUT )
ELSE
WRITE( NOUT, FMT = 9989 )PATH
END IF
ELSE
*
END IF
*
* Go back to get another input line.
*
GO TO 80
*
* Branch to this line when the last record is read.
*
140 CONTINUE
CLOSE ( NIN )
S2 = DSECND( )
WRITE( NOUT, FMT = 9998 )
WRITE( NOUT, FMT = 9997 )S2 - S1
*
9999 FORMAT( / ' Execution not attempted due to input errors' )
9998 FORMAT( / ' End of tests' )
9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
9996 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be >=',
$ I6 )
9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=',
$ I6 )
9994 FORMAT( ' Tests of the DOUBLE PRECISION LAPACK DSGESV/DSPOSV',
$ ' routines ',
$ / ' LAPACK VERSION ', I1, '.', I1, '.', I1,
$ / / ' The following parameter values will be used:' )
9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 )
9992 FORMAT( / ' Routines pass computational tests if test ratio is ',
$ 'less than', F8.2, / )
9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 )
9990 FORMAT( / 1X, A6, ' routines were not tested' )
9989 FORMAT( / 1X, A6, ' driver routines were not tested' )
*
* End of DCHKAB
*
END
Reference in New Issue View Git Blame Copy Permalink