/html/user/freeon/freeon-2010-01-14/Modules/lapack/lapack_testing/eig/schkec.f
https://github.com/jackygrahamez/DrugDiscovery-Home · FORTRAN Legacy · 181 lines · 102 code · 0 blank · 79 comment · 0 complexity · 7e775a7a8953ce38ae2a9ab97f3636aa MD5 · raw file
- SUBROUTINE SCHKEC( THRESH, TSTERR, NIN, NOUT )
- *
- * -- LAPACK test routine (version 3.1) --
- * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
- * November 2006
- *
- * .. Scalar Arguments ..
- LOGICAL TSTERR
- INTEGER NIN, NOUT
- REAL THRESH
- * ..
- *
- * Purpose
- * =======
- *
- * SCHKEC tests eigen- condition estimation routines
- * SLALN2, SLASY2, SLANV2, SLAQTR, SLAEXC,
- * STRSYL, STREXC, STRSNA, STRSEN
- *
- * In all cases, the routine runs through a fixed set of numerical
- * examples, subjects them to various tests, and compares the test
- * results to a threshold THRESH. In addition, STREXC, STRSNA and STRSEN
- * are tested by reading in precomputed examples from a file (on input
- * unit NIN). Output is written to output unit NOUT.
- *
- * Arguments
- * =========
- *
- * THRESH (input) REAL
- * Threshold for residual tests. A computed test ratio passes
- * the threshold if it is less than THRESH.
- *
- * TSTERR (input) LOGICAL
- * Flag that indicates whether error exits are to be tested.
- *
- * NIN (input) INTEGER
- * The logical unit number for input.
- *
- * NOUT (input) INTEGER
- * The logical unit number for output.
- *
- * =====================================================================
- *
- * .. Local Scalars ..
- LOGICAL OK
- CHARACTER*3 PATH
- INTEGER KLAEXC, KLALN2, KLANV2, KLAQTR, KLASY2, KTREXC,
- $ KTRSEN, KTRSNA, KTRSYL, LLAEXC, LLALN2, LLANV2,
- $ LLAQTR, LLASY2, LTREXC, LTRSYL, NLANV2, NLAQTR,
- $ NLASY2, NTESTS, NTRSYL
- REAL EPS, RLAEXC, RLALN2, RLANV2, RLAQTR, RLASY2,
- $ RTREXC, RTRSYL, SFMIN
- * ..
- * .. Local Arrays ..
- INTEGER LTRSEN( 3 ), LTRSNA( 3 ), NLAEXC( 2 ),
- $ NLALN2( 2 ), NTREXC( 3 ), NTRSEN( 3 ),
- $ NTRSNA( 3 )
- REAL RTRSEN( 3 ), RTRSNA( 3 )
- * ..
- * .. External Subroutines ..
- EXTERNAL SERREC, SGET31, SGET32, SGET33, SGET34, SGET35,
- $ SGET36, SGET37, SGET38, SGET39
- * ..
- * .. External Functions ..
- REAL SLAMCH
- EXTERNAL SLAMCH
- * ..
- * .. Executable Statements ..
- *
- PATH( 1: 1 ) = 'Single precision'
- PATH( 2: 3 ) = 'EC'
- EPS = SLAMCH( 'P' )
- SFMIN = SLAMCH( 'S' )
- *
- * Print header information
- *
- WRITE( NOUT, FMT = 9989 )
- WRITE( NOUT, FMT = 9988 )EPS, SFMIN
- WRITE( NOUT, FMT = 9987 )THRESH
- *
- * Test error exits if TSTERR is .TRUE.
- *
- IF( TSTERR )
- $ CALL SERREC( PATH, NOUT )
- *
- OK = .TRUE.
- CALL SGET31( RLALN2, LLALN2, NLALN2, KLALN2 )
- IF( RLALN2.GT.THRESH .OR. NLALN2( 1 ).NE.0 ) THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9999 )RLALN2, LLALN2, NLALN2, KLALN2
- END IF
- *
- CALL SGET32( RLASY2, LLASY2, NLASY2, KLASY2 )
- IF( RLASY2.GT.THRESH ) THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9998 )RLASY2, LLASY2, NLASY2, KLASY2
- END IF
- *
- CALL SGET33( RLANV2, LLANV2, NLANV2, KLANV2 )
- IF( RLANV2.GT.THRESH .OR. NLANV2.NE.0 ) THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9997 )RLANV2, LLANV2, NLANV2, KLANV2
- END IF
- *
- CALL SGET34( RLAEXC, LLAEXC, NLAEXC, KLAEXC )
- IF( RLAEXC.GT.THRESH .OR. NLAEXC( 2 ).NE.0 ) THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9996 )RLAEXC, LLAEXC, NLAEXC, KLAEXC
- END IF
- *
- CALL SGET35( RTRSYL, LTRSYL, NTRSYL, KTRSYL )
- IF( RTRSYL.GT.THRESH ) THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9995 )RTRSYL, LTRSYL, NTRSYL, KTRSYL
- END IF
- *
- CALL SGET36( RTREXC, LTREXC, NTREXC, KTREXC, NIN )
- IF( RTREXC.GT.THRESH .OR. NTREXC( 3 ).GT.0 ) THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9994 )RTREXC, LTREXC, NTREXC, KTREXC
- END IF
- *
- CALL SGET37( RTRSNA, LTRSNA, NTRSNA, KTRSNA, NIN )
- IF( RTRSNA( 1 ).GT.THRESH .OR. RTRSNA( 2 ).GT.THRESH .OR.
- $ NTRSNA( 1 ).NE.0 .OR. NTRSNA( 2 ).NE.0 .OR. NTRSNA( 3 ).NE.0 )
- $ THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9993 )RTRSNA, LTRSNA, NTRSNA, KTRSNA
- END IF
- *
- CALL SGET38( RTRSEN, LTRSEN, NTRSEN, KTRSEN, NIN )
- IF( RTRSEN( 1 ).GT.THRESH .OR. RTRSEN( 2 ).GT.THRESH .OR.
- $ NTRSEN( 1 ).NE.0 .OR. NTRSEN( 2 ).NE.0 .OR. NTRSEN( 3 ).NE.0 )
- $ THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9992 )RTRSEN, LTRSEN, NTRSEN, KTRSEN
- END IF
- *
- CALL SGET39( RLAQTR, LLAQTR, NLAQTR, KLAQTR )
- IF( RLAQTR.GT.THRESH ) THEN
- OK = .FALSE.
- WRITE( NOUT, FMT = 9991 )RLAQTR, LLAQTR, NLAQTR, KLAQTR
- END IF
- *
- NTESTS = KLALN2 + KLASY2 + KLANV2 + KLAEXC + KTRSYL + KTREXC +
- $ KTRSNA + KTRSEN + KLAQTR
- IF( OK )
- $ WRITE( NOUT, FMT = 9990 )PATH, NTESTS
- *
- RETURN
- 9999 FORMAT( ' Error in SLALN2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
- $ 'INFO=', 2I8, ' KNT=', I8 )
- 9998 FORMAT( ' Error in SLASY2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
- $ 'INFO=', I8, ' KNT=', I8 )
- 9997 FORMAT( ' Error in SLANV2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
- $ 'INFO=', I8, ' KNT=', I8 )
- 9996 FORMAT( ' Error in SLAEXC: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
- $ 'INFO=', 2I8, ' KNT=', I8 )
- 9995 FORMAT( ' Error in STRSYL: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
- $ 'INFO=', I8, ' KNT=', I8 )
- 9994 FORMAT( ' Error in STREXC: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
- $ 'INFO=', 3I8, ' KNT=', I8 )
- 9993 FORMAT( ' Error in STRSNA: RMAX =', 3E12.3, / ' LMAX = ', 3I8,
- $ ' NINFO=', 3I8, ' KNT=', I8 )
- 9992 FORMAT( ' Error in STRSEN: RMAX =', 3E12.3, / ' LMAX = ', 3I8,
- $ ' NINFO=', 3I8, ' KNT=', I8 )
- 9991 FORMAT( ' Error in SLAQTR: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
- $ 'INFO=', I8, ' KNT=', I8 )
- 9990 FORMAT( / 1X, 'All tests for ', A3, ' routines passed the thresh',
- $ 'old (', I6, ' tests run)' )
- 9989 FORMAT( ' Tests of the Nonsymmetric eigenproblem condition estim',
- $ 'ation routines', / ' SLALN2, SLASY2, SLANV2, SLAEXC, STRS',
- $ 'YL, STREXC, STRSNA, STRSEN, SLAQTR', / )
- 9988 FORMAT( ' Relative machine precision (EPS) = ', E16.6, / ' Safe ',
- $ 'minimum (SFMIN) = ', E16.6, / )
- 9987 FORMAT( ' Routines pass computational tests if test ratio is les',
- $ 's than', F8.2, / / )
- *
- * End of SCHKEC
- *
- END