/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

  1. SUBROUTINE SCHKEC( THRESH, TSTERR, NIN, NOUT )
  2. *
  3. * -- LAPACK test routine (version 3.1) --
  4. * Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
  5. * November 2006
  6. *
  7. * .. Scalar Arguments ..
  8. LOGICAL TSTERR
  9. INTEGER NIN, NOUT
  10. REAL THRESH
  11. * ..
  12. *
  13. * Purpose
  14. * =======
  15. *
  16. * SCHKEC tests eigen- condition estimation routines
  17. * SLALN2, SLASY2, SLANV2, SLAQTR, SLAEXC,
  18. * STRSYL, STREXC, STRSNA, STRSEN
  19. *
  20. * In all cases, the routine runs through a fixed set of numerical
  21. * examples, subjects them to various tests, and compares the test
  22. * results to a threshold THRESH. In addition, STREXC, STRSNA and STRSEN
  23. * are tested by reading in precomputed examples from a file (on input
  24. * unit NIN). Output is written to output unit NOUT.
  25. *
  26. * Arguments
  27. * =========
  28. *
  29. * THRESH (input) REAL
  30. * Threshold for residual tests. A computed test ratio passes
  31. * the threshold if it is less than THRESH.
  32. *
  33. * TSTERR (input) LOGICAL
  34. * Flag that indicates whether error exits are to be tested.
  35. *
  36. * NIN (input) INTEGER
  37. * The logical unit number for input.
  38. *
  39. * NOUT (input) INTEGER
  40. * The logical unit number for output.
  41. *
  42. * =====================================================================
  43. *
  44. * .. Local Scalars ..
  45. LOGICAL OK
  46. CHARACTER*3 PATH
  47. INTEGER KLAEXC, KLALN2, KLANV2, KLAQTR, KLASY2, KTREXC,
  48. $ KTRSEN, KTRSNA, KTRSYL, LLAEXC, LLALN2, LLANV2,
  49. $ LLAQTR, LLASY2, LTREXC, LTRSYL, NLANV2, NLAQTR,
  50. $ NLASY2, NTESTS, NTRSYL
  51. REAL EPS, RLAEXC, RLALN2, RLANV2, RLAQTR, RLASY2,
  52. $ RTREXC, RTRSYL, SFMIN
  53. * ..
  54. * .. Local Arrays ..
  55. INTEGER LTRSEN( 3 ), LTRSNA( 3 ), NLAEXC( 2 ),
  56. $ NLALN2( 2 ), NTREXC( 3 ), NTRSEN( 3 ),
  57. $ NTRSNA( 3 )
  58. REAL RTRSEN( 3 ), RTRSNA( 3 )
  59. * ..
  60. * .. External Subroutines ..
  61. EXTERNAL SERREC, SGET31, SGET32, SGET33, SGET34, SGET35,
  62. $ SGET36, SGET37, SGET38, SGET39
  63. * ..
  64. * .. External Functions ..
  65. REAL SLAMCH
  66. EXTERNAL SLAMCH
  67. * ..
  68. * .. Executable Statements ..
  69. *
  70. PATH( 1: 1 ) = 'Single precision'
  71. PATH( 2: 3 ) = 'EC'
  72. EPS = SLAMCH( 'P' )
  73. SFMIN = SLAMCH( 'S' )
  74. *
  75. * Print header information
  76. *
  77. WRITE( NOUT, FMT = 9989 )
  78. WRITE( NOUT, FMT = 9988 )EPS, SFMIN
  79. WRITE( NOUT, FMT = 9987 )THRESH
  80. *
  81. * Test error exits if TSTERR is .TRUE.
  82. *
  83. IF( TSTERR )
  84. $ CALL SERREC( PATH, NOUT )
  85. *
  86. OK = .TRUE.
  87. CALL SGET31( RLALN2, LLALN2, NLALN2, KLALN2 )
  88. IF( RLALN2.GT.THRESH .OR. NLALN2( 1 ).NE.0 ) THEN
  89. OK = .FALSE.
  90. WRITE( NOUT, FMT = 9999 )RLALN2, LLALN2, NLALN2, KLALN2
  91. END IF
  92. *
  93. CALL SGET32( RLASY2, LLASY2, NLASY2, KLASY2 )
  94. IF( RLASY2.GT.THRESH ) THEN
  95. OK = .FALSE.
  96. WRITE( NOUT, FMT = 9998 )RLASY2, LLASY2, NLASY2, KLASY2
  97. END IF
  98. *
  99. CALL SGET33( RLANV2, LLANV2, NLANV2, KLANV2 )
  100. IF( RLANV2.GT.THRESH .OR. NLANV2.NE.0 ) THEN
  101. OK = .FALSE.
  102. WRITE( NOUT, FMT = 9997 )RLANV2, LLANV2, NLANV2, KLANV2
  103. END IF
  104. *
  105. CALL SGET34( RLAEXC, LLAEXC, NLAEXC, KLAEXC )
  106. IF( RLAEXC.GT.THRESH .OR. NLAEXC( 2 ).NE.0 ) THEN
  107. OK = .FALSE.
  108. WRITE( NOUT, FMT = 9996 )RLAEXC, LLAEXC, NLAEXC, KLAEXC
  109. END IF
  110. *
  111. CALL SGET35( RTRSYL, LTRSYL, NTRSYL, KTRSYL )
  112. IF( RTRSYL.GT.THRESH ) THEN
  113. OK = .FALSE.
  114. WRITE( NOUT, FMT = 9995 )RTRSYL, LTRSYL, NTRSYL, KTRSYL
  115. END IF
  116. *
  117. CALL SGET36( RTREXC, LTREXC, NTREXC, KTREXC, NIN )
  118. IF( RTREXC.GT.THRESH .OR. NTREXC( 3 ).GT.0 ) THEN
  119. OK = .FALSE.
  120. WRITE( NOUT, FMT = 9994 )RTREXC, LTREXC, NTREXC, KTREXC
  121. END IF
  122. *
  123. CALL SGET37( RTRSNA, LTRSNA, NTRSNA, KTRSNA, NIN )
  124. IF( RTRSNA( 1 ).GT.THRESH .OR. RTRSNA( 2 ).GT.THRESH .OR.
  125. $ NTRSNA( 1 ).NE.0 .OR. NTRSNA( 2 ).NE.0 .OR. NTRSNA( 3 ).NE.0 )
  126. $ THEN
  127. OK = .FALSE.
  128. WRITE( NOUT, FMT = 9993 )RTRSNA, LTRSNA, NTRSNA, KTRSNA
  129. END IF
  130. *
  131. CALL SGET38( RTRSEN, LTRSEN, NTRSEN, KTRSEN, NIN )
  132. IF( RTRSEN( 1 ).GT.THRESH .OR. RTRSEN( 2 ).GT.THRESH .OR.
  133. $ NTRSEN( 1 ).NE.0 .OR. NTRSEN( 2 ).NE.0 .OR. NTRSEN( 3 ).NE.0 )
  134. $ THEN
  135. OK = .FALSE.
  136. WRITE( NOUT, FMT = 9992 )RTRSEN, LTRSEN, NTRSEN, KTRSEN
  137. END IF
  138. *
  139. CALL SGET39( RLAQTR, LLAQTR, NLAQTR, KLAQTR )
  140. IF( RLAQTR.GT.THRESH ) THEN
  141. OK = .FALSE.
  142. WRITE( NOUT, FMT = 9991 )RLAQTR, LLAQTR, NLAQTR, KLAQTR
  143. END IF
  144. *
  145. NTESTS = KLALN2 + KLASY2 + KLANV2 + KLAEXC + KTRSYL + KTREXC +
  146. $ KTRSNA + KTRSEN + KLAQTR
  147. IF( OK )
  148. $ WRITE( NOUT, FMT = 9990 )PATH, NTESTS
  149. *
  150. RETURN
  151. 9999 FORMAT( ' Error in SLALN2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
  152. $ 'INFO=', 2I8, ' KNT=', I8 )
  153. 9998 FORMAT( ' Error in SLASY2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
  154. $ 'INFO=', I8, ' KNT=', I8 )
  155. 9997 FORMAT( ' Error in SLANV2: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
  156. $ 'INFO=', I8, ' KNT=', I8 )
  157. 9996 FORMAT( ' Error in SLAEXC: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
  158. $ 'INFO=', 2I8, ' KNT=', I8 )
  159. 9995 FORMAT( ' Error in STRSYL: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
  160. $ 'INFO=', I8, ' KNT=', I8 )
  161. 9994 FORMAT( ' Error in STREXC: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
  162. $ 'INFO=', 3I8, ' KNT=', I8 )
  163. 9993 FORMAT( ' Error in STRSNA: RMAX =', 3E12.3, / ' LMAX = ', 3I8,
  164. $ ' NINFO=', 3I8, ' KNT=', I8 )
  165. 9992 FORMAT( ' Error in STRSEN: RMAX =', 3E12.3, / ' LMAX = ', 3I8,
  166. $ ' NINFO=', 3I8, ' KNT=', I8 )
  167. 9991 FORMAT( ' Error in SLAQTR: RMAX =', E12.3, / ' LMAX = ', I8, ' N',
  168. $ 'INFO=', I8, ' KNT=', I8 )
  169. 9990 FORMAT( / 1X, 'All tests for ', A3, ' routines passed the thresh',
  170. $ 'old (', I6, ' tests run)' )
  171. 9989 FORMAT( ' Tests of the Nonsymmetric eigenproblem condition estim',
  172. $ 'ation routines', / ' SLALN2, SLASY2, SLANV2, SLAEXC, STRS',
  173. $ 'YL, STREXC, STRSNA, STRSEN, SLAQTR', / )
  174. 9988 FORMAT( ' Relative machine precision (EPS) = ', E16.6, / ' Safe ',
  175. $ 'minimum (SFMIN) = ', E16.6, / )
  176. 9987 FORMAT( ' Routines pass computational tests if test ratio is les',
  177. $ 's than', F8.2, / / )
  178. *
  179. * End of SCHKEC
  180. *
  181. END