home *** CD-ROM | disk | FTP | other *** search
/ SGI Developer Toolbox 6.1 / SGI Developer Toolbox 6.1 - Disc 4.iso / lib / mathlib / libblas / test / sblat3.f < prev    next >
Encoding:
Text File  |  1994-08-02  |  100.6 KB  |  2,824 lines
  1.       PROGRAM SBLAT3
  2. *
  3. *  Test program for the REAL             Level 3 Blas.
  4. *
  5. *  The program must be driven by a short data file. The first 14 records
  6. *  of the file are read using list-directed input, the last 6 records
  7. *  are read using the format ( A6, L2 ). An annotated example of a data
  8. *  file can be obtained by deleting the first 3 characters from the
  9. *  following 20 lines:
  10. *  'SBLAT3.SUMM'     NAME OF SUMMARY OUTPUT FILE
  11. *  6                 UNIT NUMBER OF SUMMARY FILE
  12. *  'SBLAT3.SNAP'     NAME OF SNAPSHOT OUTPUT FILE
  13. *  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
  14. *  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
  15. *  F        LOGICAL FLAG, T TO STOP ON FAILURES.
  16. *  T        LOGICAL FLAG, T TO TEST ERROR EXITS.
  17. *  16.0     THRESHOLD VALUE OF TEST RATIO
  18. *  6                 NUMBER OF VALUES OF N
  19. *  0 1 2 3 5 9       VALUES OF N
  20. *  3                 NUMBER OF VALUES OF ALPHA
  21. *  0.0 1.0 0.7       VALUES OF ALPHA
  22. *  3                 NUMBER OF VALUES OF BETA
  23. *  0.0 1.0 1.3       VALUES OF BETA
  24. *  SGEMM  T PUT F FOR NO TEST. SAME COLUMNS.
  25. *  SSYMM  T PUT F FOR NO TEST. SAME COLUMNS.
  26. *  STRMM  T PUT F FOR NO TEST. SAME COLUMNS.
  27. *  STRSM  T PUT F FOR NO TEST. SAME COLUMNS.
  28. *  SSYRK  T PUT F FOR NO TEST. SAME COLUMNS.
  29. *  SSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
  30. *
  31. *  See:
  32. *
  33. *     Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
  34. *     A Set of Level 3 Basic Linear Algebra Subprograms.
  35. *
  36. *     Technical Memorandum No.88 (Revision 1), Mathematics and
  37. *     Computer Science Division, Argonne National Laboratory, 9700
  38. *     South Cass Avenue, Argonne, Illinois 60439, US.
  39. *
  40. *  -- Written on 8-February-1989.
  41. *     Jack Dongarra, Argonne National Laboratory.
  42. *     Iain Duff, AERE Harwell.
  43. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  44. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  45. *
  46. *     .. Parameters ..
  47.       INTEGER            NIN
  48.       PARAMETER          ( NIN = 5 )
  49.       INTEGER            NSUBS
  50.       PARAMETER          ( NSUBS = 6 )
  51.       REAL               ZERO, HALF, ONE
  52.       PARAMETER          ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
  53.       INTEGER            NMAX
  54.       PARAMETER          ( NMAX = 65 )
  55.       INTEGER            NIDMAX, NALMAX, NBEMAX
  56.       PARAMETER          ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
  57. *     .. Local Scalars ..
  58.       REAL               EPS, ERR, THRESH
  59.       INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
  60.       LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
  61.      $                   TSTERR
  62.       CHARACTER*1        TRANSA, TRANSB
  63.       CHARACTER*6        SNAMET
  64.       CHARACTER*32       SNAPS, SUMMRY
  65. *     .. Local Arrays ..
  66.       REAL               AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
  67.      $                   ALF( NALMAX ), AS( NMAX*NMAX ),
  68.      $                   BB( NMAX*NMAX ), BET( NBEMAX ),
  69.      $                   BS( NMAX*NMAX ), C( NMAX, NMAX ),
  70.      $                   CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
  71.      $                   G( NMAX ), W( 2*NMAX )
  72.       INTEGER            IDIM( NIDMAX )
  73.       LOGICAL            LTEST( NSUBS )
  74.       CHARACTER*6        SNAMES( NSUBS )
  75. *     .. External Functions ..
  76.       REAL               SDIFF
  77.       LOGICAL            LSE
  78.       EXTERNAL           SDIFF, LSE
  79. *     .. External Subroutines ..
  80.       EXTERNAL           SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHKE, SMMCH
  81. *     .. Intrinsic Functions ..
  82.       INTRINSIC          MAX, MIN
  83. *     .. Scalars in Common ..
  84.       INTEGER            INFOT, NOUTC
  85.       LOGICAL            LERR, OK
  86.       CHARACTER*6        SRNAMT
  87. *     .. Common blocks ..
  88.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  89.       COMMON             /SRNAMC/SRNAMT
  90. *     .. Data statements ..
  91.       DATA               SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ',
  92.      $                   'SSYRK ', 'SSYR2K'/
  93. *     .. Executable Statements ..
  94. *
  95. *     Read name and unit number for summary output file and open file.
  96. *
  97.       READ( NIN, FMT = * )SUMMRY
  98.       READ( NIN, FMT = * )NOUT
  99.       OPEN( NOUT, FILE = SUMMRY, STATUS = 'NEW' )
  100.       NOUTC = NOUT
  101. *
  102. *     Read name and unit number for snapshot output file and open file.
  103. *
  104.       READ( NIN, FMT = * )SNAPS
  105.       READ( NIN, FMT = * )NTRA
  106.       TRACE = NTRA.GE.0
  107.       IF( TRACE )THEN
  108.          OPEN( NTRA, FILE = SNAPS, STATUS = 'NEW' )
  109.       END IF
  110. *     Read the flag that directs rewinding of the snapshot file.
  111.       READ( NIN, FMT = * )REWI
  112.       REWI = REWI.AND.TRACE
  113. *     Read the flag that directs stopping on any failure.
  114.       READ( NIN, FMT = * )SFATAL
  115. *     Read the flag that indicates whether error exits are to be tested.
  116.       READ( NIN, FMT = * )TSTERR
  117. *     Read the threshold value of the test ratio
  118.       READ( NIN, FMT = * )THRESH
  119. *
  120. *     Read and check the parameter values for the tests.
  121. *
  122. *     Values of N
  123.       READ( NIN, FMT = * )NIDIM
  124.       IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
  125.          WRITE( NOUT, FMT = 9997 )'N', NIDMAX
  126.          GO TO 220
  127.       END IF
  128.       READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
  129.       DO 10 I = 1, NIDIM
  130.          IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
  131.             WRITE( NOUT, FMT = 9996 )NMAX
  132.             GO TO 220
  133.          END IF
  134.    10 CONTINUE
  135. *     Values of ALPHA
  136.       READ( NIN, FMT = * )NALF
  137.       IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
  138.          WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
  139.          GO TO 220
  140.       END IF
  141.       READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
  142. *     Values of BETA
  143.       READ( NIN, FMT = * )NBET
  144.       IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
  145.          WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
  146.          GO TO 220
  147.       END IF
  148.       READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
  149. *
  150. *     Report values of parameters.
  151. *
  152.       WRITE( NOUT, FMT = 9995 )
  153.       WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
  154.       WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
  155.       WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
  156.       IF( .NOT.TSTERR )THEN
  157.          WRITE( NOUT, FMT = * )
  158.          WRITE( NOUT, FMT = 9984 )
  159.       END IF
  160.       WRITE( NOUT, FMT = * )
  161.       WRITE( NOUT, FMT = 9999 )THRESH
  162.       WRITE( NOUT, FMT = * )
  163. *
  164. *     Read names of subroutines and flags which indicate
  165. *     whether they are to be tested.
  166. *
  167.       DO 20 I = 1, NSUBS
  168.          LTEST( I ) = .FALSE.
  169.    20 CONTINUE
  170.    30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
  171.       DO 40 I = 1, NSUBS
  172.          IF( SNAMET.EQ.SNAMES( I ) )
  173.      $      GO TO 50
  174.    40 CONTINUE
  175.       WRITE( NOUT, FMT = 9990 )SNAMET
  176.       STOP
  177.    50 LTEST( I ) = LTESTT
  178.       GO TO 30
  179. *
  180.    60 CONTINUE
  181.       CLOSE ( NIN )
  182. *
  183. *     Compute EPS (the machine precision).
  184. *
  185.       EPS = ONE
  186.    70 CONTINUE
  187.       IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO )
  188.      $   GO TO 80
  189.       EPS = HALF*EPS
  190.       GO TO 70
  191.    80 CONTINUE
  192.       EPS = EPS + EPS
  193.       WRITE( NOUT, FMT = 9998 )EPS
  194. *
  195. *     Check the reliability of SMMCH using exact data.
  196. *
  197.       N = MIN( 32, NMAX )
  198.       DO 100 J = 1, N
  199.          DO 90 I = 1, N
  200.             AB( I, J ) = MAX( I - J + 1, 0 )
  201.    90    CONTINUE
  202.          AB( J, NMAX + 1 ) = J
  203.          AB( 1, NMAX + J ) = J
  204.          C( J, 1 ) = ZERO
  205.   100 CONTINUE
  206.       DO 110 J = 1, N
  207.          CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
  208.   110 CONTINUE
  209. *     CC holds the exact result. On exit from SMMCH CT holds
  210. *     the result computed by SMMCH.
  211.       TRANSA = 'N'
  212.       TRANSB = 'N'
  213.       CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
  214.      $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
  215.      $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
  216.       SAME = LSE( CC, CT, N )
  217.       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
  218.          WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
  219.          STOP
  220.       END IF
  221.       TRANSB = 'T'
  222.       CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
  223.      $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
  224.      $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
  225.       SAME = LSE( CC, CT, N )
  226.       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
  227.          WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
  228.          STOP
  229.       END IF
  230.       DO 120 J = 1, N
  231.          AB( J, NMAX + 1 ) = N - J + 1
  232.          AB( 1, NMAX + J ) = N - J + 1
  233.   120 CONTINUE
  234.       DO 130 J = 1, N
  235.          CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
  236.      $                     ( ( J + 1 )*J*( J - 1 ) )/3
  237.   130 CONTINUE
  238.       TRANSA = 'T'
  239.       TRANSB = 'N'
  240.       CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
  241.      $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
  242.      $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
  243.       SAME = LSE( CC, CT, N )
  244.       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
  245.          WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
  246.          STOP
  247.       END IF
  248.       TRANSB = 'T'
  249.       CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
  250.      $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
  251.      $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
  252.       SAME = LSE( CC, CT, N )
  253.       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
  254.          WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
  255.          STOP
  256.       END IF
  257. *
  258. *     Test each subroutine in turn.
  259. *
  260.       DO 200 ISNUM = 1, NSUBS
  261.          WRITE( NOUT, FMT = * )
  262.          IF( .NOT.LTEST( ISNUM ) )THEN
  263. *           Subprogram is not to be tested.
  264.             WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
  265.          ELSE
  266.             SRNAMT = SNAMES( ISNUM )
  267. *           Test error exits.
  268.             IF( TSTERR )THEN
  269.                CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
  270.                WRITE( NOUT, FMT = * )
  271.             END IF
  272. *           Test computations.
  273.             INFOT = 0
  274.             OK = .TRUE.
  275.             FATAL = .FALSE.
  276.             GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
  277. *           Test SGEMM, 01.
  278.   140       CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  279.      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
  280.      $                  NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
  281.      $                  CC, CS, CT, G )
  282.             GO TO 190
  283. *           Test SSYMM, 02.
  284.   150       CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  285.      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
  286.      $                  NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
  287.      $                  CC, CS, CT, G )
  288.             GO TO 190
  289. *           Test STRMM, 03, STRSM, 04.
  290.   160       CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  291.      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
  292.      $                  AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
  293.             GO TO 190
  294. *           Test SSYRK, 05.
  295.   170       CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  296.      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
  297.      $                  NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
  298.      $                  CC, CS, CT, G )
  299.             GO TO 190
  300. *           Test SSYR2K, 06.
  301.   180       CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
  302.      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
  303.      $                  NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
  304.             GO TO 190
  305. *
  306.   190       IF( FATAL.AND.SFATAL )
  307.      $         GO TO 210
  308.          END IF
  309.   200 CONTINUE
  310.       WRITE( NOUT, FMT = 9986 )
  311.       GO TO 230
  312. *
  313.   210 CONTINUE
  314.       WRITE( NOUT, FMT = 9985 )
  315.       GO TO 230
  316. *
  317.   220 CONTINUE
  318.       WRITE( NOUT, FMT = 9991 )
  319. *
  320.   230 CONTINUE
  321.       IF( TRACE )
  322.      $   CLOSE ( NTRA )
  323.       CLOSE ( NOUT )
  324.       STOP
  325. *
  326.  9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
  327.      $      'S THAN', F8.2 )
  328.  9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
  329.  9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
  330.      $      'THAN ', I2 )
  331.  9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
  332.  9995 FORMAT( ' TESTS OF THE REAL             LEVEL 3 BLAS', //' THE F',
  333.      $      'OLLOWING PARAMETER VALUES WILL BE USED:' )
  334.  9994 FORMAT( '   FOR N              ', 9I6 )
  335.  9993 FORMAT( '   FOR ALPHA          ', 7F6.1 )
  336.  9992 FORMAT( '   FOR BETA           ', 7F6.1 )
  337.  9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
  338.      $      /' ******* TESTS ABANDONED *******' )
  339.  9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
  340.      $      'ESTS ABANDONED *******' )
  341.  9989 FORMAT( ' ERROR IN SMMCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',
  342.      $      'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1,
  343.      $      ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
  344.      $      'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
  345.      $      'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
  346.      $      '*******' )
  347.  9988 FORMAT( A6, L2 )
  348.  9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
  349.  9986 FORMAT( /' END OF TESTS' )
  350.  9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
  351.  9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
  352. *
  353. *     End of SBLAT3.
  354. *
  355.       END
  356.       SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  357.      $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
  358.      $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
  359. *
  360. *  Tests SGEMM.
  361. *
  362. *  Auxiliary routine for test program for Level 3 Blas.
  363. *
  364. *  -- Written on 8-February-1989.
  365. *     Jack Dongarra, Argonne National Laboratory.
  366. *     Iain Duff, AERE Harwell.
  367. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  368. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  369. *
  370. *     .. Parameters ..
  371.       REAL               ZERO
  372.       PARAMETER          ( ZERO = 0.0 )
  373. *     .. Scalar Arguments ..
  374.       REAL               EPS, THRESH
  375.       INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
  376.       LOGICAL            FATAL, REWI, TRACE
  377.       CHARACTER*6        SNAME
  378. *     .. Array Arguments ..
  379.       REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  380.      $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
  381.      $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
  382.      $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
  383.      $                   CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
  384.       INTEGER            IDIM( NIDIM )
  385. *     .. Local Scalars ..
  386.       REAL               ALPHA, ALS, BETA, BLS, ERR, ERRMAX
  387.       INTEGER            I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
  388.      $                   LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
  389.      $                   MA, MB, MS, N, NA, NARGS, NB, NC, NS
  390.       LOGICAL            NULL, RESET, SAME, TRANA, TRANB
  391.       CHARACTER*1        TRANAS, TRANBS, TRANSA, TRANSB
  392.       CHARACTER*3        ICH
  393. *     .. Local Arrays ..
  394.       LOGICAL            ISAME( 13 )
  395. *     .. External Functions ..
  396.       LOGICAL            LSE, LSERES
  397.       EXTERNAL           LSE, LSERES
  398. *     .. External Subroutines ..
  399.       EXTERNAL           SGEMM, SMAKE, SMMCH
  400. *     .. Intrinsic Functions ..
  401.       INTRINSIC          MAX
  402. *     .. Scalars in Common ..
  403.       INTEGER            INFOT, NOUTC
  404.       LOGICAL            LERR, OK
  405. *     .. Common blocks ..
  406.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  407. *     .. Data statements ..
  408.       DATA               ICH/'NTC'/
  409. *     .. Executable Statements ..
  410. *
  411.       NARGS = 13
  412.       NC = 0
  413.       RESET = .TRUE.
  414.       ERRMAX = ZERO
  415. *
  416.       DO 110 IM = 1, NIDIM
  417.          M = IDIM( IM )
  418. *
  419.          DO 100 IN = 1, NIDIM
  420.             N = IDIM( IN )
  421. *           Set LDC to 1 more than minimum value if room.
  422.             LDC = M
  423.             IF( LDC.LT.NMAX )
  424.      $         LDC = LDC + 1
  425. *           Skip tests if not enough room.
  426.             IF( LDC.GT.NMAX )
  427.      $         GO TO 100
  428.             LCC = LDC*N
  429.             NULL = N.LE.0.OR.M.LE.0
  430. *
  431.             DO 90 IK = 1, NIDIM
  432.                K = IDIM( IK )
  433. *
  434.                DO 80 ICA = 1, 3
  435.                   TRANSA = ICH( ICA: ICA )
  436.                   TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
  437. *
  438.                   IF( TRANA )THEN
  439.                      MA = K
  440.                      NA = M
  441.                   ELSE
  442.                      MA = M
  443.                      NA = K
  444.                   END IF
  445. *                 Set LDA to 1 more than minimum value if room.
  446.                   LDA = MA
  447.                   IF( LDA.LT.NMAX )
  448.      $               LDA = LDA + 1
  449. *                 Skip tests if not enough room.
  450.                   IF( LDA.GT.NMAX )
  451.      $               GO TO 80
  452.                   LAA = LDA*NA
  453. *
  454. *                 Generate the matrix A.
  455. *
  456.                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
  457.      $                        RESET, ZERO )
  458. *
  459.                   DO 70 ICB = 1, 3
  460.                      TRANSB = ICH( ICB: ICB )
  461.                      TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
  462. *
  463.                      IF( TRANB )THEN
  464.                         MB = N
  465.                         NB = K
  466.                      ELSE
  467.                         MB = K
  468.                         NB = N
  469.                      END IF
  470. *                    Set LDB to 1 more than minimum value if room.
  471.                      LDB = MB
  472.                      IF( LDB.LT.NMAX )
  473.      $                  LDB = LDB + 1
  474. *                    Skip tests if not enough room.
  475.                      IF( LDB.GT.NMAX )
  476.      $                  GO TO 70
  477.                      LBB = LDB*NB
  478. *
  479. *                    Generate the matrix B.
  480. *
  481.                      CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
  482.      $                           LDB, RESET, ZERO )
  483. *
  484.                      DO 60 IA = 1, NALF
  485.                         ALPHA = ALF( IA )
  486. *
  487.                         DO 50 IB = 1, NBET
  488.                            BETA = BET( IB )
  489. *
  490. *                          Generate the matrix C.
  491. *
  492.                            CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
  493.      $                                 CC, LDC, RESET, ZERO )
  494. *
  495.                            NC = NC + 1
  496. *
  497. *                          Save every datum before calling the
  498. *                          subroutine.
  499. *
  500.                            TRANAS = TRANSA
  501.                            TRANBS = TRANSB
  502.                            MS = M
  503.                            NS = N
  504.                            KS = K
  505.                            ALS = ALPHA
  506.                            DO 10 I = 1, LAA
  507.                               AS( I ) = AA( I )
  508.    10                      CONTINUE
  509.                            LDAS = LDA
  510.                            DO 20 I = 1, LBB
  511.                               BS( I ) = BB( I )
  512.    20                      CONTINUE
  513.                            LDBS = LDB
  514.                            BLS = BETA
  515.                            DO 30 I = 1, LCC
  516.                               CS( I ) = CC( I )
  517.    30                      CONTINUE
  518.                            LDCS = LDC
  519. *
  520. *                          Call the subroutine.
  521. *
  522.                            IF( TRACE )
  523.      $                        WRITE( NTRA, FMT = 9995 )NC, SNAME,
  524.      $                        TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
  525.      $                        BETA, LDC
  526.                            IF( REWI )
  527.      $                        REWIND NTRA
  528.                            CALL SGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
  529.      $                                 AA, LDA, BB, LDB, BETA, CC, LDC )
  530. *
  531. *                          Check if error-exit was taken incorrectly.
  532. *
  533.                            IF( .NOT.OK )THEN
  534.                               WRITE( NOUT, FMT = 9994 )
  535.                               FATAL = .TRUE.
  536.                               GO TO 120
  537.                            END IF
  538. *
  539. *                          See what data changed inside subroutines.
  540. *
  541.                            ISAME( 1 ) = TRANSA.EQ.TRANAS
  542.                            ISAME( 2 ) = TRANSB.EQ.TRANBS
  543.                            ISAME( 3 ) = MS.EQ.M
  544.                            ISAME( 4 ) = NS.EQ.N
  545.                            ISAME( 5 ) = KS.EQ.K
  546.                            ISAME( 6 ) = ALS.EQ.ALPHA
  547.                            ISAME( 7 ) = LSE( AS, AA, LAA )
  548.                            ISAME( 8 ) = LDAS.EQ.LDA
  549.                            ISAME( 9 ) = LSE( BS, BB, LBB )
  550.                            ISAME( 10 ) = LDBS.EQ.LDB
  551.                            ISAME( 11 ) = BLS.EQ.BETA
  552.                            IF( NULL )THEN
  553.                               ISAME( 12 ) = LSE( CS, CC, LCC )
  554.                            ELSE
  555.                               ISAME( 12 ) = LSERES( 'GE', ' ', M, N, CS,
  556.      $                                      CC, LDC )
  557.                            END IF
  558.                            ISAME( 13 ) = LDCS.EQ.LDC
  559. *
  560. *                          If data was incorrectly changed, report
  561. *                          and return.
  562. *
  563.                            SAME = .TRUE.
  564.                            DO 40 I = 1, NARGS
  565.                               SAME = SAME.AND.ISAME( I )
  566.                               IF( .NOT.ISAME( I ) )
  567.      $                           WRITE( NOUT, FMT = 9998 )I
  568.    40                      CONTINUE
  569.                            IF( .NOT.SAME )THEN
  570.                               FATAL = .TRUE.
  571.                               GO TO 120
  572.                            END IF
  573. *
  574.                            IF( .NOT.NULL )THEN
  575. *
  576. *                             Check the result.
  577. *
  578.                               CALL SMMCH( TRANSA, TRANSB, M, N, K,
  579.      $                                    ALPHA, A, NMAX, B, NMAX, BETA,
  580.      $                                    C, NMAX, CT, G, CC, LDC, EPS,
  581.      $                                    ERR, FATAL, NOUT, .TRUE. )
  582.                               ERRMAX = MAX( ERRMAX, ERR )
  583. *                             If got really bad answer, report and
  584. *                             return.
  585.                               IF( FATAL )
  586.      $                           GO TO 120
  587.                            END IF
  588. *
  589.    50                   CONTINUE
  590. *
  591.    60                CONTINUE
  592. *
  593.    70             CONTINUE
  594. *
  595.    80          CONTINUE
  596. *
  597.    90       CONTINUE
  598. *
  599.   100    CONTINUE
  600. *
  601.   110 CONTINUE
  602. *
  603. *     Report result.
  604. *
  605.       IF( ERRMAX.LT.THRESH )THEN
  606.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  607.       ELSE
  608.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  609.       END IF
  610.       GO TO 130
  611. *
  612.   120 CONTINUE
  613.       WRITE( NOUT, FMT = 9996 )SNAME
  614.       WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
  615.      $   ALPHA, LDA, LDB, BETA, LDC
  616. *
  617.   130 CONTINUE
  618.       RETURN
  619. *
  620.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  621.      $      'S)' )
  622.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  623.      $      'ANGED INCORRECTLY *******' )
  624.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  625.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  626.      $      ' - SUSPECT *******' )
  627.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  628.  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
  629.      $      3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
  630.      $      'C,', I3, ').' )
  631.  9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  632.      $      '******' )
  633. *
  634. *     End of SCHK1.
  635. *
  636.       END
  637.       SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  638.      $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
  639.      $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
  640. *
  641. *  Tests SSYMM.
  642. *
  643. *  Auxiliary routine for test program for Level 3 Blas.
  644. *
  645. *  -- Written on 8-February-1989.
  646. *     Jack Dongarra, Argonne National Laboratory.
  647. *     Iain Duff, AERE Harwell.
  648. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  649. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  650. *
  651. *     .. Parameters ..
  652.       REAL               ZERO
  653.       PARAMETER          ( ZERO = 0.0 )
  654. *     .. Scalar Arguments ..
  655.       REAL               EPS, THRESH
  656.       INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
  657.       LOGICAL            FATAL, REWI, TRACE
  658.       CHARACTER*6        SNAME
  659. *     .. Array Arguments ..
  660.       REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  661.      $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
  662.      $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
  663.      $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
  664.      $                   CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
  665.       INTEGER            IDIM( NIDIM )
  666. *     .. Local Scalars ..
  667.       REAL               ALPHA, ALS, BETA, BLS, ERR, ERRMAX
  668.       INTEGER            I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
  669.      $                   LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
  670.      $                   NARGS, NC, NS
  671.       LOGICAL            LEFT, NULL, RESET, SAME
  672.       CHARACTER*1        SIDE, SIDES, UPLO, UPLOS
  673.       CHARACTER*2        ICHS, ICHU
  674. *     .. Local Arrays ..
  675.       LOGICAL            ISAME( 13 )
  676. *     .. External Functions ..
  677.       LOGICAL            LSE, LSERES
  678.       EXTERNAL           LSE, LSERES
  679. *     .. External Subroutines ..
  680.       EXTERNAL           SMAKE, SMMCH, SSYMM
  681. *     .. Intrinsic Functions ..
  682.       INTRINSIC          MAX
  683. *     .. Scalars in Common ..
  684.       INTEGER            INFOT, NOUTC
  685.       LOGICAL            LERR, OK
  686. *     .. Common blocks ..
  687.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  688. *     .. Data statements ..
  689.       DATA               ICHS/'LR'/, ICHU/'UL'/
  690. *     .. Executable Statements ..
  691. *
  692.       NARGS = 12
  693.       NC = 0
  694.       RESET = .TRUE.
  695.       ERRMAX = ZERO
  696. *
  697.       DO 100 IM = 1, NIDIM
  698.          M = IDIM( IM )
  699. *
  700.          DO 90 IN = 1, NIDIM
  701.             N = IDIM( IN )
  702. *           Set LDC to 1 more than minimum value if room.
  703.             LDC = M
  704.             IF( LDC.LT.NMAX )
  705.      $         LDC = LDC + 1
  706. *           Skip tests if not enough room.
  707.             IF( LDC.GT.NMAX )
  708.      $         GO TO 90
  709.             LCC = LDC*N
  710.             NULL = N.LE.0.OR.M.LE.0
  711. *
  712. *           Set LDB to 1 more than minimum value if room.
  713.             LDB = M
  714.             IF( LDB.LT.NMAX )
  715.      $         LDB = LDB + 1
  716. *           Skip tests if not enough room.
  717.             IF( LDB.GT.NMAX )
  718.      $         GO TO 90
  719.             LBB = LDB*N
  720. *
  721. *           Generate the matrix B.
  722. *
  723.             CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
  724.      $                  ZERO )
  725. *
  726.             DO 80 ICS = 1, 2
  727.                SIDE = ICHS( ICS: ICS )
  728.                LEFT = SIDE.EQ.'L'
  729. *
  730.                IF( LEFT )THEN
  731.                   NA = M
  732.                ELSE
  733.                   NA = N
  734.                END IF
  735. *              Set LDA to 1 more than minimum value if room.
  736.                LDA = NA
  737.                IF( LDA.LT.NMAX )
  738.      $            LDA = LDA + 1
  739. *              Skip tests if not enough room.
  740.                IF( LDA.GT.NMAX )
  741.      $            GO TO 80
  742.                LAA = LDA*NA
  743. *
  744.                DO 70 ICU = 1, 2
  745.                   UPLO = ICHU( ICU: ICU )
  746. *
  747. *                 Generate the symmetric matrix A.
  748. *
  749.                   CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA,
  750.      $                        RESET, ZERO )
  751. *
  752.                   DO 60 IA = 1, NALF
  753.                      ALPHA = ALF( IA )
  754. *
  755.                      DO 50 IB = 1, NBET
  756.                         BETA = BET( IB )
  757. *
  758. *                       Generate the matrix C.
  759. *
  760.                         CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
  761.      $                              LDC, RESET, ZERO )
  762. *
  763.                         NC = NC + 1
  764. *
  765. *                       Save every datum before calling the
  766. *                       subroutine.
  767. *
  768.                         SIDES = SIDE
  769.                         UPLOS = UPLO
  770.                         MS = M
  771.                         NS = N
  772.                         ALS = ALPHA
  773.                         DO 10 I = 1, LAA
  774.                            AS( I ) = AA( I )
  775.    10                   CONTINUE
  776.                         LDAS = LDA
  777.                         DO 20 I = 1, LBB
  778.                            BS( I ) = BB( I )
  779.    20                   CONTINUE
  780.                         LDBS = LDB
  781.                         BLS = BETA
  782.                         DO 30 I = 1, LCC
  783.                            CS( I ) = CC( I )
  784.    30                   CONTINUE
  785.                         LDCS = LDC
  786. *
  787. *                       Call the subroutine.
  788. *
  789.                         IF( TRACE )
  790.      $                     WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
  791.      $                     UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
  792.                         IF( REWI )
  793.      $                     REWIND NTRA
  794.                         CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
  795.      $                              BB, LDB, BETA, CC, LDC )
  796. *
  797. *                       Check if error-exit was taken incorrectly.
  798. *
  799.                         IF( .NOT.OK )THEN
  800.                            WRITE( NOUT, FMT = 9994 )
  801.                            FATAL = .TRUE.
  802.                            GO TO 110
  803.                         END IF
  804. *
  805. *                       See what data changed inside subroutines.
  806. *
  807.                         ISAME( 1 ) = SIDES.EQ.SIDE
  808.                         ISAME( 2 ) = UPLOS.EQ.UPLO
  809.                         ISAME( 3 ) = MS.EQ.M
  810.                         ISAME( 4 ) = NS.EQ.N
  811.                         ISAME( 5 ) = ALS.EQ.ALPHA
  812.                         ISAME( 6 ) = LSE( AS, AA, LAA )
  813.                         ISAME( 7 ) = LDAS.EQ.LDA
  814.                         ISAME( 8 ) = LSE( BS, BB, LBB )
  815.                         ISAME( 9 ) = LDBS.EQ.LDB
  816.                         ISAME( 10 ) = BLS.EQ.BETA
  817.                         IF( NULL )THEN
  818.                            ISAME( 11 ) = LSE( CS, CC, LCC )
  819.                         ELSE
  820.                            ISAME( 11 ) = LSERES( 'GE', ' ', M, N, CS,
  821.      $                                   CC, LDC )
  822.                         END IF
  823.                         ISAME( 12 ) = LDCS.EQ.LDC
  824. *
  825. *                       If data was incorrectly changed, report and
  826. *                       return.
  827. *
  828.                         SAME = .TRUE.
  829.                         DO 40 I = 1, NARGS
  830.                            SAME = SAME.AND.ISAME( I )
  831.                            IF( .NOT.ISAME( I ) )
  832.      $                        WRITE( NOUT, FMT = 9998 )I
  833.    40                   CONTINUE
  834.                         IF( .NOT.SAME )THEN
  835.                            FATAL = .TRUE.
  836.                            GO TO 110
  837.                         END IF
  838. *
  839.                         IF( .NOT.NULL )THEN
  840. *
  841. *                          Check the result.
  842. *
  843.                            IF( LEFT )THEN
  844.                               CALL SMMCH( 'N', 'N', M, N, M, ALPHA, A,
  845.      $                                    NMAX, B, NMAX, BETA, C, NMAX,
  846.      $                                    CT, G, CC, LDC, EPS, ERR,
  847.      $                                    FATAL, NOUT, .TRUE. )
  848.                            ELSE
  849.                               CALL SMMCH( 'N', 'N', M, N, N, ALPHA, B,
  850.      $                                    NMAX, A, NMAX, BETA, C, NMAX,
  851.      $                                    CT, G, CC, LDC, EPS, ERR,
  852.      $                                    FATAL, NOUT, .TRUE. )
  853.                            END IF
  854.                            ERRMAX = MAX( ERRMAX, ERR )
  855. *                          If got really bad answer, report and
  856. *                          return.
  857.                            IF( FATAL )
  858.      $                        GO TO 110
  859.                         END IF
  860. *
  861.    50                CONTINUE
  862. *
  863.    60             CONTINUE
  864. *
  865.    70          CONTINUE
  866. *
  867.    80       CONTINUE
  868. *
  869.    90    CONTINUE
  870. *
  871.   100 CONTINUE
  872. *
  873. *     Report result.
  874. *
  875.       IF( ERRMAX.LT.THRESH )THEN
  876.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  877.       ELSE
  878.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  879.       END IF
  880.       GO TO 120
  881. *
  882.   110 CONTINUE
  883.       WRITE( NOUT, FMT = 9996 )SNAME
  884.       WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
  885.      $   LDB, BETA, LDC
  886. *
  887.   120 CONTINUE
  888.       RETURN
  889. *
  890.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  891.      $      'S)' )
  892.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  893.      $      'ANGED INCORRECTLY *******' )
  894.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  895.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  896.      $      ' - SUSPECT *******' )
  897.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  898.  9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
  899.      $      F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ')   ',
  900.      $      ' .' )
  901.  9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  902.      $      '******' )
  903. *
  904. *     End of SCHK2.
  905. *
  906.       END
  907.       SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  908.      $                  FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
  909.      $                  B, BB, BS, CT, G, C )
  910. *
  911. *  Tests STRMM and STRSM.
  912. *
  913. *  Auxiliary routine for test program for Level 3 Blas.
  914. *
  915. *  -- Written on 8-February-1989.
  916. *     Jack Dongarra, Argonne National Laboratory.
  917. *     Iain Duff, AERE Harwell.
  918. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  919. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  920. *
  921. *     .. Parameters ..
  922.       REAL               ZERO, ONE
  923.       PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
  924. *     .. Scalar Arguments ..
  925.       REAL               EPS, THRESH
  926.       INTEGER            NALF, NIDIM, NMAX, NOUT, NTRA
  927.       LOGICAL            FATAL, REWI, TRACE
  928.       CHARACTER*6        SNAME
  929. *     .. Array Arguments ..
  930.       REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  931.      $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
  932.      $                   BB( NMAX*NMAX ), BS( NMAX*NMAX ),
  933.      $                   C( NMAX, NMAX ), CT( NMAX ), G( NMAX )
  934.       INTEGER            IDIM( NIDIM )
  935. *     .. Local Scalars ..
  936.       REAL               ALPHA, ALS, ERR, ERRMAX
  937.       INTEGER            I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
  938.      $                   LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
  939.      $                   NS
  940.       LOGICAL            LEFT, NULL, RESET, SAME
  941.       CHARACTER*1        DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
  942.      $                   UPLOS
  943.       CHARACTER*2        ICHD, ICHS, ICHU
  944.       CHARACTER*3        ICHT
  945. *     .. Local Arrays ..
  946.       LOGICAL            ISAME( 13 )
  947. *     .. External Functions ..
  948.       LOGICAL            LSE, LSERES
  949.       EXTERNAL           LSE, LSERES
  950. *     .. External Subroutines ..
  951.       EXTERNAL           SMAKE, SMMCH, STRMM, STRSM
  952. *     .. Intrinsic Functions ..
  953.       INTRINSIC          MAX
  954. *     .. Scalars in Common ..
  955.       INTEGER            INFOT, NOUTC
  956.       LOGICAL            LERR, OK
  957. *     .. Common blocks ..
  958.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  959. *     .. Data statements ..
  960.       DATA               ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
  961. *     .. Executable Statements ..
  962. *
  963.       NARGS = 11
  964.       NC = 0
  965.       RESET = .TRUE.
  966.       ERRMAX = ZERO
  967. *     Set up zero matrix for SMMCH.
  968.       DO 20 J = 1, NMAX
  969.          DO 10 I = 1, NMAX
  970.             C( I, J ) = ZERO
  971.    10    CONTINUE
  972.    20 CONTINUE
  973. *
  974.       DO 140 IM = 1, NIDIM
  975.          M = IDIM( IM )
  976. *
  977.          DO 130 IN = 1, NIDIM
  978.             N = IDIM( IN )
  979. *           Set LDB to 1 more than minimum value if room.
  980.             LDB = M
  981.             IF( LDB.LT.NMAX )
  982.      $         LDB = LDB + 1
  983. *           Skip tests if not enough room.
  984.             IF( LDB.GT.NMAX )
  985.      $         GO TO 130
  986.             LBB = LDB*N
  987.             NULL = M.LE.0.OR.N.LE.0
  988. *
  989.             DO 120 ICS = 1, 2
  990.                SIDE = ICHS( ICS: ICS )
  991.                LEFT = SIDE.EQ.'L'
  992.                IF( LEFT )THEN
  993.                   NA = M
  994.                ELSE
  995.                   NA = N
  996.                END IF
  997. *              Set LDA to 1 more than minimum value if room.
  998.                LDA = NA
  999.                IF( LDA.LT.NMAX )
  1000.      $            LDA = LDA + 1
  1001. *              Skip tests if not enough room.
  1002.                IF( LDA.GT.NMAX )
  1003.      $            GO TO 130
  1004.                LAA = LDA*NA
  1005. *
  1006.                DO 110 ICU = 1, 2
  1007.                   UPLO = ICHU( ICU: ICU )
  1008. *
  1009.                   DO 100 ICT = 1, 3
  1010.                      TRANSA = ICHT( ICT: ICT )
  1011. *
  1012.                      DO 90 ICD = 1, 2
  1013.                         DIAG = ICHD( ICD: ICD )
  1014. *
  1015.                         DO 80 IA = 1, NALF
  1016.                            ALPHA = ALF( IA )
  1017. *
  1018. *                          Generate the matrix A.
  1019. *
  1020.                            CALL SMAKE( 'TR', UPLO, DIAG, NA, NA, A,
  1021.      $                                 NMAX, AA, LDA, RESET, ZERO )
  1022. *
  1023. *                          Generate the matrix B.
  1024. *
  1025.                            CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
  1026.      $                                 BB, LDB, RESET, ZERO )
  1027. *
  1028.                            NC = NC + 1
  1029. *
  1030. *                          Save every datum before calling the
  1031. *                          subroutine.
  1032. *
  1033.                            SIDES = SIDE
  1034.                            UPLOS = UPLO
  1035.                            TRANAS = TRANSA
  1036.                            DIAGS = DIAG
  1037.                            MS = M
  1038.                            NS = N
  1039.                            ALS = ALPHA
  1040.                            DO 30 I = 1, LAA
  1041.                               AS( I ) = AA( I )
  1042.    30                      CONTINUE
  1043.                            LDAS = LDA
  1044.                            DO 40 I = 1, LBB
  1045.                               BS( I ) = BB( I )
  1046.    40                      CONTINUE
  1047.                            LDBS = LDB
  1048. *
  1049. *                          Call the subroutine.
  1050. *
  1051.                            IF( SNAME( 4: 5 ).EQ.'MM' )THEN
  1052.                               IF( TRACE )
  1053.      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
  1054.      $                           SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
  1055.      $                           LDA, LDB
  1056.                               IF( REWI )
  1057.      $                           REWIND NTRA
  1058.                               CALL STRMM( SIDE, UPLO, TRANSA, DIAG, M,
  1059.      $                                    N, ALPHA, AA, LDA, BB, LDB )
  1060.                            ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
  1061.                               IF( TRACE )
  1062.      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
  1063.      $                           SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
  1064.      $                           LDA, LDB
  1065.                               IF( REWI )
  1066.      $                           REWIND NTRA
  1067.                               CALL STRSM( SIDE, UPLO, TRANSA, DIAG, M,
  1068.      $                                    N, ALPHA, AA, LDA, BB, LDB )
  1069.                            END IF
  1070. *
  1071. *                          Check if error-exit was taken incorrectly.
  1072. *
  1073.                            IF( .NOT.OK )THEN
  1074.                               WRITE( NOUT, FMT = 9994 )
  1075.                               FATAL = .TRUE.
  1076.                               GO TO 150
  1077.                            END IF
  1078. *
  1079. *                          See what data changed inside subroutines.
  1080. *
  1081.                            ISAME( 1 ) = SIDES.EQ.SIDE
  1082.                            ISAME( 2 ) = UPLOS.EQ.UPLO
  1083.                            ISAME( 3 ) = TRANAS.EQ.TRANSA
  1084.                            ISAME( 4 ) = DIAGS.EQ.DIAG
  1085.                            ISAME( 5 ) = MS.EQ.M
  1086.                            ISAME( 6 ) = NS.EQ.N
  1087.                            ISAME( 7 ) = ALS.EQ.ALPHA
  1088.                            ISAME( 8 ) = LSE( AS, AA, LAA )
  1089.                            ISAME( 9 ) = LDAS.EQ.LDA
  1090.                            IF( NULL )THEN
  1091.                               ISAME( 10 ) = LSE( BS, BB, LBB )
  1092.                            ELSE
  1093.                               ISAME( 10 ) = LSERES( 'GE', ' ', M, N, BS,
  1094.      $                                      BB, LDB )
  1095.                            END IF
  1096.                            ISAME( 11 ) = LDBS.EQ.LDB
  1097. *
  1098. *                          If data was incorrectly changed, report and
  1099. *                          return.
  1100. *
  1101.                            SAME = .TRUE.
  1102.                            DO 50 I = 1, NARGS
  1103.                               SAME = SAME.AND.ISAME( I )
  1104.                               IF( .NOT.ISAME( I ) )
  1105.      $                           WRITE( NOUT, FMT = 9998 )I
  1106.    50                      CONTINUE
  1107.                            IF( .NOT.SAME )THEN
  1108.                               FATAL = .TRUE.
  1109.                               GO TO 150
  1110.                            END IF
  1111. *
  1112.                            IF( .NOT.NULL )THEN
  1113.                               IF( SNAME( 4: 5 ).EQ.'MM' )THEN
  1114. *
  1115. *                                Check the result.
  1116. *
  1117.                                  IF( LEFT )THEN
  1118.                                     CALL SMMCH( TRANSA, 'N', M, N, M,
  1119.      $                                          ALPHA, A, NMAX, B, NMAX,
  1120.      $                                          ZERO, C, NMAX, CT, G,
  1121.      $                                          BB, LDB, EPS, ERR,
  1122.      $                                          FATAL, NOUT, .TRUE. )
  1123.                                  ELSE
  1124.                                     CALL SMMCH( 'N', TRANSA, M, N, N,
  1125.      $                                          ALPHA, B, NMAX, A, NMAX,
  1126.      $                                          ZERO, C, NMAX, CT, G,
  1127.      $                                          BB, LDB, EPS, ERR,
  1128.      $                                          FATAL, NOUT, .TRUE. )
  1129.                                  END IF
  1130.                               ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
  1131. *
  1132. *                                Compute approximation to original
  1133. *                                matrix.
  1134. *
  1135.                                  DO 70 J = 1, N
  1136.                                     DO 60 I = 1, M
  1137.                                        C( I, J ) = BB( I + ( J - 1 )*
  1138.      $                                             LDB )
  1139.                                        BB( I + ( J - 1 )*LDB ) = ALPHA*
  1140.      $                                    B( I, J )
  1141.    60                               CONTINUE
  1142.    70                            CONTINUE
  1143. *
  1144.                                  IF( LEFT )THEN
  1145.                                     CALL SMMCH( TRANSA, 'N', M, N, M,
  1146.      $                                          ONE, A, NMAX, C, NMAX,
  1147.      $                                          ZERO, B, NMAX, CT, G,
  1148.      $                                          BB, LDB, EPS, ERR,
  1149.      $                                          FATAL, NOUT, .FALSE. )
  1150.                                  ELSE
  1151.                                     CALL SMMCH( 'N', TRANSA, M, N, N,
  1152.      $                                          ONE, C, NMAX, A, NMAX,
  1153.      $                                          ZERO, B, NMAX, CT, G,
  1154.      $                                          BB, LDB, EPS, ERR,
  1155.      $                                          FATAL, NOUT, .FALSE. )
  1156.                                  END IF
  1157.                               END IF
  1158.                               ERRMAX = MAX( ERRMAX, ERR )
  1159. *                             If got really bad answer, report and
  1160. *                             return.
  1161.                               IF( FATAL )
  1162.      $                           GO TO 150
  1163.                            END IF
  1164. *
  1165.    80                   CONTINUE
  1166. *
  1167.    90                CONTINUE
  1168. *
  1169.   100             CONTINUE
  1170. *
  1171.   110          CONTINUE
  1172. *
  1173.   120       CONTINUE
  1174. *
  1175.   130    CONTINUE
  1176. *
  1177.   140 CONTINUE
  1178. *
  1179. *     Report result.
  1180. *
  1181.       IF( ERRMAX.LT.THRESH )THEN
  1182.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  1183.       ELSE
  1184.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  1185.       END IF
  1186.       GO TO 160
  1187. *
  1188.   150 CONTINUE
  1189.       WRITE( NOUT, FMT = 9996 )SNAME
  1190.       WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
  1191.      $   N, ALPHA, LDA, LDB
  1192. *
  1193.   160 CONTINUE
  1194.       RETURN
  1195. *
  1196.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  1197.      $      'S)' )
  1198.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  1199.      $      'ANGED INCORRECTLY *******' )
  1200.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  1201.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  1202.      $      ' - SUSPECT *******' )
  1203.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  1204.  9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
  1205.      $      F4.1, ', A,', I3, ', B,', I3, ')        .' )
  1206.  9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  1207.      $      '******' )
  1208. *
  1209. *     End of SCHK3.
  1210. *
  1211.       END
  1212.       SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  1213.      $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
  1214.      $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
  1215. *
  1216. *  Tests SSYRK.
  1217. *
  1218. *  Auxiliary routine for test program for Level 3 Blas.
  1219. *
  1220. *  -- Written on 8-February-1989.
  1221. *     Jack Dongarra, Argonne National Laboratory.
  1222. *     Iain Duff, AERE Harwell.
  1223. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  1224. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  1225. *
  1226. *     .. Parameters ..
  1227.       REAL               ZERO
  1228.       PARAMETER          ( ZERO = 0.0 )
  1229. *     .. Scalar Arguments ..
  1230.       REAL               EPS, THRESH
  1231.       INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
  1232.       LOGICAL            FATAL, REWI, TRACE
  1233.       CHARACTER*6        SNAME
  1234. *     .. Array Arguments ..
  1235.       REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
  1236.      $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
  1237.      $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
  1238.      $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
  1239.      $                   CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
  1240.       INTEGER            IDIM( NIDIM )
  1241. *     .. Local Scalars ..
  1242.       REAL               ALPHA, ALS, BETA, BETS, ERR, ERRMAX
  1243.       INTEGER            I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
  1244.      $                   LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
  1245.      $                   NARGS, NC, NS
  1246.       LOGICAL            NULL, RESET, SAME, TRAN, UPPER
  1247.       CHARACTER*1        TRANS, TRANSS, UPLO, UPLOS
  1248.       CHARACTER*2        ICHU
  1249.       CHARACTER*3        ICHT
  1250. *     .. Local Arrays ..
  1251.       LOGICAL            ISAME( 13 )
  1252. *     .. External Functions ..
  1253.       LOGICAL            LSE, LSERES
  1254.       EXTERNAL           LSE, LSERES
  1255. *     .. External Subroutines ..
  1256.       EXTERNAL           SMAKE, SMMCH, SSYRK
  1257. *     .. Intrinsic Functions ..
  1258.       INTRINSIC          MAX
  1259. *     .. Scalars in Common ..
  1260.       INTEGER            INFOT, NOUTC
  1261.       LOGICAL            LERR, OK
  1262. *     .. Common blocks ..
  1263.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  1264. *     .. Data statements ..
  1265.       DATA               ICHT/'NTC'/, ICHU/'UL'/
  1266. *     .. Executable Statements ..
  1267. *
  1268.       NARGS = 10
  1269.       NC = 0
  1270.       RESET = .TRUE.
  1271.       ERRMAX = ZERO
  1272. *
  1273.       DO 100 IN = 1, NIDIM
  1274.          N = IDIM( IN )
  1275. *        Set LDC to 1 more than minimum value if room.
  1276.          LDC = N
  1277.          IF( LDC.LT.NMAX )
  1278.      $      LDC = LDC + 1
  1279. *        Skip tests if not enough room.
  1280.          IF( LDC.GT.NMAX )
  1281.      $      GO TO 100
  1282.          LCC = LDC*N
  1283.          NULL = N.LE.0
  1284. *
  1285.          DO 90 IK = 1, NIDIM
  1286.             K = IDIM( IK )
  1287. *
  1288.             DO 80 ICT = 1, 3
  1289.                TRANS = ICHT( ICT: ICT )
  1290.                TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
  1291.                IF( TRAN )THEN
  1292.                   MA = K
  1293.                   NA = N
  1294.                ELSE
  1295.                   MA = N
  1296.                   NA = K
  1297.                END IF
  1298. *              Set LDA to 1 more than minimum value if room.
  1299.                LDA = MA
  1300.                IF( LDA.LT.NMAX )
  1301.      $            LDA = LDA + 1
  1302. *              Skip tests if not enough room.
  1303.                IF( LDA.GT.NMAX )
  1304.      $            GO TO 80
  1305.                LAA = LDA*NA
  1306. *
  1307. *              Generate the matrix A.
  1308. *
  1309.                CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
  1310.      $                     RESET, ZERO )
  1311. *
  1312.                DO 70 ICU = 1, 2
  1313.                   UPLO = ICHU( ICU: ICU )
  1314.                   UPPER = UPLO.EQ.'U'
  1315. *
  1316.                   DO 60 IA = 1, NALF
  1317.                      ALPHA = ALF( IA )
  1318. *
  1319.                      DO 50 IB = 1, NBET
  1320.                         BETA = BET( IB )
  1321. *
  1322. *                       Generate the matrix C.
  1323. *
  1324.                         CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
  1325.      $                              LDC, RESET, ZERO )
  1326. *
  1327.                         NC = NC + 1
  1328. *
  1329. *                       Save every datum before calling the subroutine.
  1330. *
  1331.                         UPLOS = UPLO
  1332.                         TRANSS = TRANS
  1333.                         NS = N
  1334.                         KS = K
  1335.                         ALS = ALPHA
  1336.                         DO 10 I = 1, LAA
  1337.                            AS( I ) = AA( I )
  1338.    10                   CONTINUE
  1339.                         LDAS = LDA
  1340.                         BETS = BETA
  1341.                         DO 20 I = 1, LCC
  1342.                            CS( I ) = CC( I )
  1343.    20                   CONTINUE
  1344.                         LDCS = LDC
  1345. *
  1346. *                       Call the subroutine.
  1347. *
  1348.                         IF( TRACE )
  1349.      $                     WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
  1350.      $                     TRANS, N, K, ALPHA, LDA, BETA, LDC
  1351.                         IF( REWI )
  1352.      $                     REWIND NTRA
  1353.                         CALL SSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA,
  1354.      $                              BETA, CC, LDC )
  1355. *
  1356. *                       Check if error-exit was taken incorrectly.
  1357. *
  1358.                         IF( .NOT.OK )THEN
  1359.                            WRITE( NOUT, FMT = 9993 )
  1360.                            FATAL = .TRUE.
  1361.                            GO TO 120
  1362.                         END IF
  1363. *
  1364. *                       See what data changed inside subroutines.
  1365. *
  1366.                         ISAME( 1 ) = UPLOS.EQ.UPLO
  1367.                         ISAME( 2 ) = TRANSS.EQ.TRANS
  1368.                         ISAME( 3 ) = NS.EQ.N
  1369.                         ISAME( 4 ) = KS.EQ.K
  1370.                         ISAME( 5 ) = ALS.EQ.ALPHA
  1371.                         ISAME( 6 ) = LSE( AS, AA, LAA )
  1372.                         ISAME( 7 ) = LDAS.EQ.LDA
  1373.                         ISAME( 8 ) = BETS.EQ.BETA
  1374.                         IF( NULL )THEN
  1375.                            ISAME( 9 ) = LSE( CS, CC, LCC )
  1376.                         ELSE
  1377.                            ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS,
  1378.      $                                  CC, LDC )
  1379.                         END IF
  1380.                         ISAME( 10 ) = LDCS.EQ.LDC
  1381. *
  1382. *                       If data was incorrectly changed, report and
  1383. *                       return.
  1384. *
  1385.                         SAME = .TRUE.
  1386.                         DO 30 I = 1, NARGS
  1387.                            SAME = SAME.AND.ISAME( I )
  1388.                            IF( .NOT.ISAME( I ) )
  1389.      $                        WRITE( NOUT, FMT = 9998 )I
  1390.    30                   CONTINUE
  1391.                         IF( .NOT.SAME )THEN
  1392.                            FATAL = .TRUE.
  1393.                            GO TO 120
  1394.                         END IF
  1395. *
  1396.                         IF( .NOT.NULL )THEN
  1397. *
  1398. *                          Check the result column by column.
  1399. *
  1400.                            JC = 1
  1401.                            DO 40 J = 1, N
  1402.                               IF( UPPER )THEN
  1403.                                  JJ = 1
  1404.                                  LJ = J
  1405.                               ELSE
  1406.                                  JJ = J
  1407.                                  LJ = N - J + 1
  1408.                               END IF
  1409.                               IF( TRAN )THEN
  1410.                                  CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA,
  1411.      $                                       A( 1, JJ ), NMAX,
  1412.      $                                       A( 1, J ), NMAX, BETA,
  1413.      $                                       C( JJ, J ), NMAX, CT, G,
  1414.      $                                       CC( JC ), LDC, EPS, ERR,
  1415.      $                                       FATAL, NOUT, .TRUE. )
  1416.                               ELSE
  1417.                                  CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA,
  1418.      $                                       A( JJ, 1 ), NMAX,
  1419.      $                                       A( J, 1 ), NMAX, BETA,
  1420.      $                                       C( JJ, J ), NMAX, CT, G,
  1421.      $                                       CC( JC ), LDC, EPS, ERR,
  1422.      $                                       FATAL, NOUT, .TRUE. )
  1423.                               END IF
  1424.                               IF( UPPER )THEN
  1425.                                  JC = JC + LDC
  1426.                               ELSE
  1427.                                  JC = JC + LDC + 1
  1428.                               END IF
  1429.                               ERRMAX = MAX( ERRMAX, ERR )
  1430. *                             If got really bad answer, report and
  1431. *                             return.
  1432.                               IF( FATAL )
  1433.      $                           GO TO 110
  1434.    40                      CONTINUE
  1435.                         END IF
  1436. *
  1437.    50                CONTINUE
  1438. *
  1439.    60             CONTINUE
  1440. *
  1441.    70          CONTINUE
  1442. *
  1443.    80       CONTINUE
  1444. *
  1445.    90    CONTINUE
  1446. *
  1447.   100 CONTINUE
  1448. *
  1449. *     Report result.
  1450. *
  1451.       IF( ERRMAX.LT.THRESH )THEN
  1452.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  1453.       ELSE
  1454.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  1455.       END IF
  1456.       GO TO 130
  1457. *
  1458.   110 CONTINUE
  1459.       IF( N.GT.1 )
  1460.      $   WRITE( NOUT, FMT = 9995 )J
  1461. *
  1462.   120 CONTINUE
  1463.       WRITE( NOUT, FMT = 9996 )SNAME
  1464.       WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
  1465.      $   LDA, BETA, LDC
  1466. *
  1467.   130 CONTINUE
  1468.       RETURN
  1469. *
  1470.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  1471.      $      'S)' )
  1472.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  1473.      $      'ANGED INCORRECTLY *******' )
  1474.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  1475.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  1476.      $      ' - SUSPECT *******' )
  1477.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  1478.  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
  1479.  9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
  1480.      $      F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ')           .' )
  1481.  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  1482.      $      '******' )
  1483. *
  1484. *     End of SCHK4.
  1485. *
  1486.       END
  1487.       SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
  1488.      $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
  1489.      $                  AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
  1490. *
  1491. *  Tests SSYR2K.
  1492. *
  1493. *  Auxiliary routine for test program for Level 3 Blas.
  1494. *
  1495. *  -- Written on 8-February-1989.
  1496. *     Jack Dongarra, Argonne National Laboratory.
  1497. *     Iain Duff, AERE Harwell.
  1498. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  1499. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  1500. *
  1501. *     .. Parameters ..
  1502.       REAL               ZERO
  1503.       PARAMETER          ( ZERO = 0.0 )
  1504. *     .. Scalar Arguments ..
  1505.       REAL               EPS, THRESH
  1506.       INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
  1507.       LOGICAL            FATAL, REWI, TRACE
  1508.       CHARACTER*6        SNAME
  1509. *     .. Array Arguments ..
  1510.       REAL               AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
  1511.      $                   ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
  1512.      $                   BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
  1513.      $                   CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
  1514.      $                   G( NMAX ), W( 2*NMAX )
  1515.       INTEGER            IDIM( NIDIM )
  1516. *     .. Local Scalars ..
  1517.       REAL               ALPHA, ALS, BETA, BETS, ERR, ERRMAX
  1518.       INTEGER            I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
  1519.      $                   K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
  1520.      $                   LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
  1521.       LOGICAL            NULL, RESET, SAME, TRAN, UPPER
  1522.       CHARACTER*1        TRANS, TRANSS, UPLO, UPLOS
  1523.       CHARACTER*2        ICHU
  1524.       CHARACTER*3        ICHT
  1525. *     .. Local Arrays ..
  1526.       LOGICAL            ISAME( 13 )
  1527. *     .. External Functions ..
  1528.       LOGICAL            LSE, LSERES
  1529.       EXTERNAL           LSE, LSERES
  1530. *     .. External Subroutines ..
  1531.       EXTERNAL           SMAKE, SMMCH, SSYR2K
  1532. *     .. Intrinsic Functions ..
  1533.       INTRINSIC          MAX
  1534. *     .. Scalars in Common ..
  1535.       INTEGER            INFOT, NOUTC
  1536.       LOGICAL            LERR, OK
  1537. *     .. Common blocks ..
  1538.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  1539. *     .. Data statements ..
  1540.       DATA               ICHT/'NTC'/, ICHU/'UL'/
  1541. *     .. Executable Statements ..
  1542. *
  1543.       NARGS = 12
  1544.       NC = 0
  1545.       RESET = .TRUE.
  1546.       ERRMAX = ZERO
  1547. *
  1548.       DO 130 IN = 1, NIDIM
  1549.          N = IDIM( IN )
  1550. *        Set LDC to 1 more than minimum value if room.
  1551.          LDC = N
  1552.          IF( LDC.LT.NMAX )
  1553.      $      LDC = LDC + 1
  1554. *        Skip tests if not enough room.
  1555.          IF( LDC.GT.NMAX )
  1556.      $      GO TO 130
  1557.          LCC = LDC*N
  1558.          NULL = N.LE.0
  1559. *
  1560.          DO 120 IK = 1, NIDIM
  1561.             K = IDIM( IK )
  1562. *
  1563.             DO 110 ICT = 1, 3
  1564.                TRANS = ICHT( ICT: ICT )
  1565.                TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
  1566.                IF( TRAN )THEN
  1567.                   MA = K
  1568.                   NA = N
  1569.                ELSE
  1570.                   MA = N
  1571.                   NA = K
  1572.                END IF
  1573. *              Set LDA to 1 more than minimum value if room.
  1574.                LDA = MA
  1575.                IF( LDA.LT.NMAX )
  1576.      $            LDA = LDA + 1
  1577. *              Skip tests if not enough room.
  1578.                IF( LDA.GT.NMAX )
  1579.      $            GO TO 110
  1580.                LAA = LDA*NA
  1581. *
  1582. *              Generate the matrix A.
  1583. *
  1584.                IF( TRAN )THEN
  1585.                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
  1586.      $                        LDA, RESET, ZERO )
  1587.                ELSE
  1588.                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
  1589.      $                        RESET, ZERO )
  1590.                END IF
  1591. *
  1592. *              Generate the matrix B.
  1593. *
  1594.                LDB = LDA
  1595.                LBB = LAA
  1596.                IF( TRAN )THEN
  1597.                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
  1598.      $                        2*NMAX, BB, LDB, RESET, ZERO )
  1599.                ELSE
  1600.                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
  1601.      $                        NMAX, BB, LDB, RESET, ZERO )
  1602.                END IF
  1603. *
  1604.                DO 100 ICU = 1, 2
  1605.                   UPLO = ICHU( ICU: ICU )
  1606.                   UPPER = UPLO.EQ.'U'
  1607. *
  1608.                   DO 90 IA = 1, NALF
  1609.                      ALPHA = ALF( IA )
  1610. *
  1611.                      DO 80 IB = 1, NBET
  1612.                         BETA = BET( IB )
  1613. *
  1614. *                       Generate the matrix C.
  1615. *
  1616.                         CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
  1617.      $                              LDC, RESET, ZERO )
  1618. *
  1619.                         NC = NC + 1
  1620. *
  1621. *                       Save every datum before calling the subroutine.
  1622. *
  1623.                         UPLOS = UPLO
  1624.                         TRANSS = TRANS
  1625.                         NS = N
  1626.                         KS = K
  1627.                         ALS = ALPHA
  1628.                         DO 10 I = 1, LAA
  1629.                            AS( I ) = AA( I )
  1630.    10                   CONTINUE
  1631.                         LDAS = LDA
  1632.                         DO 20 I = 1, LBB
  1633.                            BS( I ) = BB( I )
  1634.    20                   CONTINUE
  1635.                         LDBS = LDB
  1636.                         BETS = BETA
  1637.                         DO 30 I = 1, LCC
  1638.                            CS( I ) = CC( I )
  1639.    30                   CONTINUE
  1640.                         LDCS = LDC
  1641. *
  1642. *                       Call the subroutine.
  1643. *
  1644.                         IF( TRACE )
  1645.      $                     WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
  1646.      $                     TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
  1647.                         IF( REWI )
  1648.      $                     REWIND NTRA
  1649.                         CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA,
  1650.      $                               BB, LDB, BETA, CC, LDC )
  1651. *
  1652. *                       Check if error-exit was taken incorrectly.
  1653. *
  1654.                         IF( .NOT.OK )THEN
  1655.                            WRITE( NOUT, FMT = 9993 )
  1656.                            FATAL = .TRUE.
  1657.                            GO TO 150
  1658.                         END IF
  1659. *
  1660. *                       See what data changed inside subroutines.
  1661. *
  1662.                         ISAME( 1 ) = UPLOS.EQ.UPLO
  1663.                         ISAME( 2 ) = TRANSS.EQ.TRANS
  1664.                         ISAME( 3 ) = NS.EQ.N
  1665.                         ISAME( 4 ) = KS.EQ.K
  1666.                         ISAME( 5 ) = ALS.EQ.ALPHA
  1667.                         ISAME( 6 ) = LSE( AS, AA, LAA )
  1668.                         ISAME( 7 ) = LDAS.EQ.LDA
  1669.                         ISAME( 8 ) = LSE( BS, BB, LBB )
  1670.                         ISAME( 9 ) = LDBS.EQ.LDB
  1671.                         ISAME( 10 ) = BETS.EQ.BETA
  1672.                         IF( NULL )THEN
  1673.                            ISAME( 11 ) = LSE( CS, CC, LCC )
  1674.                         ELSE
  1675.                            ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS,
  1676.      $                                   CC, LDC )
  1677.                         END IF
  1678.                         ISAME( 12 ) = LDCS.EQ.LDC
  1679. *
  1680. *                       If data was incorrectly changed, report and
  1681. *                       return.
  1682. *
  1683.                         SAME = .TRUE.
  1684.                         DO 40 I = 1, NARGS
  1685.                            SAME = SAME.AND.ISAME( I )
  1686.                            IF( .NOT.ISAME( I ) )
  1687.      $                        WRITE( NOUT, FMT = 9998 )I
  1688.    40                   CONTINUE
  1689.                         IF( .NOT.SAME )THEN
  1690.                            FATAL = .TRUE.
  1691.                            GO TO 150
  1692.                         END IF
  1693. *
  1694.                         IF( .NOT.NULL )THEN
  1695. *
  1696. *                          Check the result column by column.
  1697. *
  1698.                            JJAB = 1
  1699.                            JC = 1
  1700.                            DO 70 J = 1, N
  1701.                               IF( UPPER )THEN
  1702.                                  JJ = 1
  1703.                                  LJ = J
  1704.                               ELSE
  1705.                                  JJ = J
  1706.                                  LJ = N - J + 1
  1707.                               END IF
  1708.                               IF( TRAN )THEN
  1709.                                  DO 50 I = 1, K
  1710.                                     W( I ) = AB( ( J - 1 )*2*NMAX + K +
  1711.      $                                       I )
  1712.                                     W( K + I ) = AB( ( J - 1 )*2*NMAX +
  1713.      $                                           I )
  1714.    50                            CONTINUE
  1715.                                  CALL SMMCH( 'T', 'N', LJ, 1, 2*K,
  1716.      $                                       ALPHA, AB( JJAB ), 2*NMAX,
  1717.      $                                       W, 2*NMAX, BETA,
  1718.      $                                       C( JJ, J ), NMAX, CT, G,
  1719.      $                                       CC( JC ), LDC, EPS, ERR,
  1720.      $                                       FATAL, NOUT, .TRUE. )
  1721.                               ELSE
  1722.                                  DO 60 I = 1, K
  1723.                                     W( I ) = AB( ( K + I - 1 )*NMAX +
  1724.      $                                       J )
  1725.                                     W( K + I ) = AB( ( I - 1 )*NMAX +
  1726.      $                                           J )
  1727.    60                            CONTINUE
  1728.                                  CALL SMMCH( 'N', 'N', LJ, 1, 2*K,
  1729.      $                                       ALPHA, AB( JJ ), NMAX, W,
  1730.      $                                       2*NMAX, BETA, C( JJ, J ),
  1731.      $                                       NMAX, CT, G, CC( JC ), LDC,
  1732.      $                                       EPS, ERR, FATAL, NOUT,
  1733.      $                                       .TRUE. )
  1734.                               END IF
  1735.                               IF( UPPER )THEN
  1736.                                  JC = JC + LDC
  1737.                               ELSE
  1738.                                  JC = JC + LDC + 1
  1739.                                  IF( TRAN )
  1740.      $                              JJAB = JJAB + 2*NMAX
  1741.                               END IF
  1742.                               ERRMAX = MAX( ERRMAX, ERR )
  1743. *                             If got really bad answer, report and
  1744. *                             return.
  1745.                               IF( FATAL )
  1746.      $                           GO TO 140
  1747.    70                      CONTINUE
  1748.                         END IF
  1749. *
  1750.    80                CONTINUE
  1751. *
  1752.    90             CONTINUE
  1753. *
  1754.   100          CONTINUE
  1755. *
  1756.   110       CONTINUE
  1757. *
  1758.   120    CONTINUE
  1759. *
  1760.   130 CONTINUE
  1761. *
  1762. *     Report result.
  1763. *
  1764.       IF( ERRMAX.LT.THRESH )THEN
  1765.          WRITE( NOUT, FMT = 9999 )SNAME, NC
  1766.       ELSE
  1767.          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
  1768.       END IF
  1769.       GO TO 160
  1770. *
  1771.   140 CONTINUE
  1772.       IF( N.GT.1 )
  1773.      $   WRITE( NOUT, FMT = 9995 )J
  1774. *
  1775.   150 CONTINUE
  1776.       WRITE( NOUT, FMT = 9996 )SNAME
  1777.       WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
  1778.      $   LDA, LDB, BETA, LDC
  1779. *
  1780.   160 CONTINUE
  1781.       RETURN
  1782. *
  1783.  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
  1784.      $      'S)' )
  1785.  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
  1786.      $      'ANGED INCORRECTLY *******' )
  1787.  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
  1788.      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
  1789.      $      ' - SUSPECT *******' )
  1790.  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
  1791.  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
  1792.  9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
  1793.      $      F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ')   ',
  1794.      $      ' .' )
  1795.  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
  1796.      $      '******' )
  1797. *
  1798. *     End of SCHK5.
  1799. *
  1800.       END
  1801.       SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT )
  1802. *
  1803. *  Tests the error exits from the Level 3 Blas.
  1804. *  Requires a special version of the error-handling routine XERBLA.
  1805. *  ALPHA, BETA, A, B and C should not need to be defined.
  1806. *
  1807. *  Auxiliary routine for test program for Level 3 Blas.
  1808. *
  1809. *  -- Written on 8-February-1989.
  1810. *     Jack Dongarra, Argonne National Laboratory.
  1811. *     Iain Duff, AERE Harwell.
  1812. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  1813. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  1814. *
  1815. *     .. Scalar Arguments ..
  1816.       INTEGER            ISNUM, NOUT
  1817.       CHARACTER*6        SRNAMT
  1818. *     .. Scalars in Common ..
  1819.       INTEGER            INFOT, NOUTC
  1820.       LOGICAL            LERR, OK
  1821. *     .. Local Scalars ..
  1822.       REAL               ALPHA, BETA
  1823. *     .. Local Arrays ..
  1824.       REAL               A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
  1825. *     .. External Subroutines ..
  1826.       EXTERNAL           CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM,
  1827.      $                   STRSM
  1828. *     .. Common blocks ..
  1829.       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
  1830. *     .. Executable Statements ..
  1831. *     OK is set to .FALSE. by the special version of XERBLA or by CHKXER
  1832. *     if anything is wrong.
  1833.       OK = .TRUE.
  1834. *     LERR is set to .TRUE. by the special version of XERBLA each time
  1835. *     it is called, and is then tested and re-set by CHKXER.
  1836.       LERR = .FALSE.
  1837.       GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
  1838.    10 INFOT = 1
  1839.       CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1840.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1841.       INFOT = 1
  1842.       CALL SGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1843.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1844.       INFOT = 2
  1845.       CALL SGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1846.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1847.       INFOT = 2
  1848.       CALL SGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1849.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1850.       INFOT = 3
  1851.       CALL SGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1852.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1853.       INFOT = 3
  1854.       CALL SGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1855.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1856.       INFOT = 3
  1857.       CALL SGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1858.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1859.       INFOT = 3
  1860.       CALL SGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1861.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1862.       INFOT = 4
  1863.       CALL SGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1864.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1865.       INFOT = 4
  1866.       CALL SGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1867.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1868.       INFOT = 4
  1869.       CALL SGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1870.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1871.       INFOT = 4
  1872.       CALL SGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1873.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1874.       INFOT = 5
  1875.       CALL SGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1876.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1877.       INFOT = 5
  1878.       CALL SGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1879.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1880.       INFOT = 5
  1881.       CALL SGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1882.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1883.       INFOT = 5
  1884.       CALL SGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1885.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1886.       INFOT = 8
  1887.       CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
  1888.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1889.       INFOT = 8
  1890.       CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
  1891.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1892.       INFOT = 8
  1893.       CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
  1894.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1895.       INFOT = 8
  1896.       CALL SGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1897.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1898.       INFOT = 10
  1899.       CALL SGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1900.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1901.       INFOT = 10
  1902.       CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
  1903.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1904.       INFOT = 10
  1905.       CALL SGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1906.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1907.       INFOT = 10
  1908.       CALL SGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1909.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1910.       INFOT = 13
  1911.       CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
  1912.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1913.       INFOT = 13
  1914.       CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
  1915.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1916.       INFOT = 13
  1917.       CALL SGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1918.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1919.       INFOT = 13
  1920.       CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1921.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1922.       GO TO 70
  1923.    20 INFOT = 1
  1924.       CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1925.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1926.       INFOT = 2
  1927.       CALL SSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1928.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1929.       INFOT = 3
  1930.       CALL SSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1931.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1932.       INFOT = 3
  1933.       CALL SSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1934.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1935.       INFOT = 3
  1936.       CALL SSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1937.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1938.       INFOT = 3
  1939.       CALL SSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1940.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1941.       INFOT = 4
  1942.       CALL SSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1943.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1944.       INFOT = 4
  1945.       CALL SSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1946.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1947.       INFOT = 4
  1948.       CALL SSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1949.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1950.       INFOT = 4
  1951.       CALL SSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1952.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1953.       INFOT = 7
  1954.       CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
  1955.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1956.       INFOT = 7
  1957.       CALL SSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1958.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1959.       INFOT = 7
  1960.       CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
  1961.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1962.       INFOT = 7
  1963.       CALL SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1964.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1965.       INFOT = 9
  1966.       CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
  1967.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1968.       INFOT = 9
  1969.       CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1970.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1971.       INFOT = 9
  1972.       CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
  1973.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1974.       INFOT = 9
  1975.       CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  1976.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1977.       INFOT = 12
  1978.       CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
  1979.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1980.       INFOT = 12
  1981.       CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
  1982.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1983.       INFOT = 12
  1984.       CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
  1985.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1986.       INFOT = 12
  1987.       CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
  1988.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1989.       GO TO 70
  1990.    30 INFOT = 1
  1991.       CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
  1992.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1993.       INFOT = 2
  1994.       CALL STRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
  1995.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1996.       INFOT = 3
  1997.       CALL STRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
  1998.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  1999.       INFOT = 4
  2000.       CALL STRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
  2001.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2002.       INFOT = 5
  2003.       CALL STRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2004.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2005.       INFOT = 5
  2006.       CALL STRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2007.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2008.       INFOT = 5
  2009.       CALL STRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2010.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2011.       INFOT = 5
  2012.       CALL STRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2013.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2014.       INFOT = 5
  2015.       CALL STRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2016.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2017.       INFOT = 5
  2018.       CALL STRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2019.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2020.       INFOT = 5
  2021.       CALL STRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2022.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2023.       INFOT = 5
  2024.       CALL STRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2025.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2026.       INFOT = 6
  2027.       CALL STRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2028.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2029.       INFOT = 6
  2030.       CALL STRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2031.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2032.       INFOT = 6
  2033.       CALL STRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2034.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2035.       INFOT = 6
  2036.       CALL STRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2037.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2038.       INFOT = 6
  2039.       CALL STRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2040.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2041.       INFOT = 6
  2042.       CALL STRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2043.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2044.       INFOT = 6
  2045.       CALL STRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2046.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2047.       INFOT = 6
  2048.       CALL STRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2049.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2050.       INFOT = 9
  2051.       CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
  2052.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2053.       INFOT = 9
  2054.       CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
  2055.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2056.       INFOT = 9
  2057.       CALL STRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
  2058.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2059.       INFOT = 9
  2060.       CALL STRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
  2061.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2062.       INFOT = 9
  2063.       CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
  2064.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2065.       INFOT = 9
  2066.       CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
  2067.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2068.       INFOT = 9
  2069.       CALL STRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
  2070.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2071.       INFOT = 9
  2072.       CALL STRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
  2073.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2074.       INFOT = 11
  2075.       CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
  2076.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2077.       INFOT = 11
  2078.       CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
  2079.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2080.       INFOT = 11
  2081.       CALL STRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
  2082.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2083.       INFOT = 11
  2084.       CALL STRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
  2085.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2086.       INFOT = 11
  2087.       CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
  2088.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2089.       INFOT = 11
  2090.       CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
  2091.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2092.       INFOT = 11
  2093.       CALL STRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
  2094.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2095.       INFOT = 11
  2096.       CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
  2097.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2098.       GO TO 70
  2099.    40 INFOT = 1
  2100.       CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
  2101.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2102.       INFOT = 2
  2103.       CALL STRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
  2104.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2105.       INFOT = 3
  2106.       CALL STRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
  2107.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2108.       INFOT = 4
  2109.       CALL STRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
  2110.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2111.       INFOT = 5
  2112.       CALL STRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2113.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2114.       INFOT = 5
  2115.       CALL STRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2116.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2117.       INFOT = 5
  2118.       CALL STRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2119.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2120.       INFOT = 5
  2121.       CALL STRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2122.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2123.       INFOT = 5
  2124.       CALL STRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2125.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2126.       INFOT = 5
  2127.       CALL STRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2128.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2129.       INFOT = 5
  2130.       CALL STRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2131.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2132.       INFOT = 5
  2133.       CALL STRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
  2134.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2135.       INFOT = 6
  2136.       CALL STRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2137.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2138.       INFOT = 6
  2139.       CALL STRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2140.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2141.       INFOT = 6
  2142.       CALL STRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2143.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2144.       INFOT = 6
  2145.       CALL STRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2146.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2147.       INFOT = 6
  2148.       CALL STRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2149.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2150.       INFOT = 6
  2151.       CALL STRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2152.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2153.       INFOT = 6
  2154.       CALL STRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2155.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2156.       INFOT = 6
  2157.       CALL STRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
  2158.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2159.       INFOT = 9
  2160.       CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
  2161.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2162.       INFOT = 9
  2163.       CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
  2164.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2165.       INFOT = 9
  2166.       CALL STRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
  2167.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2168.       INFOT = 9
  2169.       CALL STRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
  2170.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2171.       INFOT = 9
  2172.       CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
  2173.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2174.       INFOT = 9
  2175.       CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
  2176.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2177.       INFOT = 9
  2178.       CALL STRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
  2179.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2180.       INFOT = 9
  2181.       CALL STRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
  2182.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2183.       INFOT = 11
  2184.       CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
  2185.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2186.       INFOT = 11
  2187.       CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
  2188.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2189.       INFOT = 11
  2190.       CALL STRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
  2191.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2192.       INFOT = 11
  2193.       CALL STRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
  2194.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2195.       INFOT = 11
  2196.       CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
  2197.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2198.       INFOT = 11
  2199.       CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
  2200.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2201.       INFOT = 11
  2202.       CALL STRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
  2203.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2204.       INFOT = 11
  2205.       CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
  2206.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2207.       GO TO 70
  2208.    50 INFOT = 1
  2209.       CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
  2210.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2211.       INFOT = 2
  2212.       CALL SSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 )
  2213.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2214.       INFOT = 3
  2215.       CALL SSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
  2216.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2217.       INFOT = 3
  2218.       CALL SSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
  2219.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2220.       INFOT = 3
  2221.       CALL SSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
  2222.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2223.       INFOT = 3
  2224.       CALL SSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
  2225.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2226.       INFOT = 4
  2227.       CALL SSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
  2228.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2229.       INFOT = 4
  2230.       CALL SSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
  2231.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2232.       INFOT = 4
  2233.       CALL SSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
  2234.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2235.       INFOT = 4
  2236.       CALL SSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
  2237.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2238.       INFOT = 7
  2239.       CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
  2240.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2241.       INFOT = 7
  2242.       CALL SSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
  2243.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2244.       INFOT = 7
  2245.       CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
  2246.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2247.       INFOT = 7
  2248.       CALL SSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
  2249.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2250.       INFOT = 10
  2251.       CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
  2252.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2253.       INFOT = 10
  2254.       CALL SSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
  2255.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2256.       INFOT = 10
  2257.       CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
  2258.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2259.       INFOT = 10
  2260.       CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
  2261.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2262.       GO TO 70
  2263.    60 INFOT = 1
  2264.       CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2265.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2266.       INFOT = 2
  2267.       CALL SSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2268.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2269.       INFOT = 3
  2270.       CALL SSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2271.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2272.       INFOT = 3
  2273.       CALL SSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2274.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2275.       INFOT = 3
  2276.       CALL SSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2277.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2278.       INFOT = 3
  2279.       CALL SSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2280.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2281.       INFOT = 4
  2282.       CALL SSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2283.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2284.       INFOT = 4
  2285.       CALL SSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2286.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2287.       INFOT = 4
  2288.       CALL SSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2289.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2290.       INFOT = 4
  2291.       CALL SSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2292.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2293.       INFOT = 7
  2294.       CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
  2295.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2296.       INFOT = 7
  2297.       CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2298.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2299.       INFOT = 7
  2300.       CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
  2301.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2302.       INFOT = 7
  2303.       CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2304.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2305.       INFOT = 9
  2306.       CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
  2307.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2308.       INFOT = 9
  2309.       CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
  2310.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2311.       INFOT = 9
  2312.       CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
  2313.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2314.       INFOT = 9
  2315.       CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
  2316.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2317.       INFOT = 12
  2318.       CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
  2319.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2320.       INFOT = 12
  2321.       CALL SSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2322.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2323.       INFOT = 12
  2324.       CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
  2325.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2326.       INFOT = 12
  2327.       CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
  2328.       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2329. *
  2330.    70 IF( OK )THEN
  2331.          WRITE( NOUT, FMT = 9999 )SRNAMT
  2332.       ELSE
  2333.          WRITE( NOUT, FMT = 9998 )SRNAMT
  2334.       END IF
  2335.       RETURN
  2336. *
  2337.  9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
  2338.  9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
  2339.      $      '**' )
  2340. *
  2341. *     End of SCHKE.
  2342. *
  2343.       END
  2344.       SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
  2345.      $                  TRANSL )
  2346. *
  2347. *  Generates values for an M by N matrix A.
  2348. *  Stores the values in the array AA in the data structure required
  2349. *  by the routine, with unwanted elements set to rogue value.
  2350. *
  2351. *  TYPE is 'GE', 'SY' or 'TR'.
  2352. *
  2353. *  Auxiliary routine for test program for Level 3 Blas.
  2354. *
  2355. *  -- Written on 8-February-1989.
  2356. *     Jack Dongarra, Argonne National Laboratory.
  2357. *     Iain Duff, AERE Harwell.
  2358. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  2359. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  2360. *
  2361. *     .. Parameters ..
  2362.       REAL               ZERO, ONE
  2363.       PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
  2364.       REAL               ROGUE
  2365.       PARAMETER          ( ROGUE = -1.0E10 )
  2366. *     .. Scalar Arguments ..
  2367.       REAL               TRANSL
  2368.       INTEGER            LDA, M, N, NMAX
  2369.       LOGICAL            RESET
  2370.       CHARACTER*1        DIAG, UPLO
  2371.       CHARACTER*2        TYPE
  2372. *     .. Array Arguments ..
  2373.       REAL               A( NMAX, * ), AA( * )
  2374. *     .. Local Scalars ..
  2375.       INTEGER            I, IBEG, IEND, J
  2376.       LOGICAL            GEN, LOWER, SYM, TRI, UNIT, UPPER
  2377. *     .. External Functions ..
  2378.       REAL               SBEG
  2379.       EXTERNAL           SBEG
  2380. *     .. Executable Statements ..
  2381.       GEN = TYPE.EQ.'GE'
  2382.       SYM = TYPE.EQ.'SY'
  2383.       TRI = TYPE.EQ.'TR'
  2384.       UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
  2385.       LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
  2386.       UNIT = TRI.AND.DIAG.EQ.'U'
  2387. *
  2388. *     Generate data in array A.
  2389. *
  2390.       DO 20 J = 1, N
  2391.          DO 10 I = 1, M
  2392.             IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
  2393.      $          THEN
  2394.                A( I, J ) = SBEG( RESET ) + TRANSL
  2395.                IF( I.NE.J )THEN
  2396. *                 Set some elements to zero
  2397.                   IF( N.GT.3.AND.J.EQ.N/2 )
  2398.      $               A( I, J ) = ZERO
  2399.                   IF( SYM )THEN
  2400.                      A( J, I ) = A( I, J )
  2401.                   ELSE IF( TRI )THEN
  2402.                      A( J, I ) = ZERO
  2403.                   END IF
  2404.                END IF
  2405.             END IF
  2406.    10    CONTINUE
  2407.          IF( TRI )
  2408.      $      A( J, J ) = A( J, J ) + ONE
  2409.          IF( UNIT )
  2410.      $      A( J, J ) = ONE
  2411.    20 CONTINUE
  2412. *
  2413. *     Store elements in array AS in data structure required by routine.
  2414. *
  2415.       IF( TYPE.EQ.'GE' )THEN
  2416.          DO 50 J = 1, N
  2417.             DO 30 I = 1, M
  2418.                AA( I + ( J - 1 )*LDA ) = A( I, J )
  2419.    30       CONTINUE
  2420.             DO 40 I = M + 1, LDA
  2421.                AA( I + ( J - 1 )*LDA ) = ROGUE
  2422.    40       CONTINUE
  2423.    50    CONTINUE
  2424.       ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
  2425.          DO 90 J = 1, N
  2426.             IF( UPPER )THEN
  2427.                IBEG = 1
  2428.                IF( UNIT )THEN
  2429.                   IEND = J - 1
  2430.                ELSE
  2431.                   IEND = J
  2432.                END IF
  2433.             ELSE
  2434.                IF( UNIT )THEN
  2435.                   IBEG = J + 1
  2436.                ELSE
  2437.                   IBEG = J
  2438.                END IF
  2439.                IEND = N
  2440.             END IF
  2441.             DO 60 I = 1, IBEG - 1
  2442.                AA( I + ( J - 1 )*LDA ) = ROGUE
  2443.    60       CONTINUE
  2444.             DO 70 I = IBEG, IEND
  2445.                AA( I + ( J - 1 )*LDA ) = A( I, J )
  2446.    70       CONTINUE
  2447.             DO 80 I = IEND + 1, LDA
  2448.                AA( I + ( J - 1 )*LDA ) = ROGUE
  2449.    80       CONTINUE
  2450.    90    CONTINUE
  2451.       END IF
  2452.       RETURN
  2453. *
  2454. *     End of SMAKE.
  2455. *
  2456.       END
  2457.       SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
  2458.      $                  BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
  2459.      $                  NOUT, MV )
  2460. *
  2461. *  Checks the results of the computational tests.
  2462. *
  2463. *  Auxiliary routine for test program for Level 3 Blas.
  2464. *
  2465. *  -- Written on 8-February-1989.
  2466. *     Jack Dongarra, Argonne National Laboratory.
  2467. *     Iain Duff, AERE Harwell.
  2468. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  2469. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  2470. *
  2471. *     .. Parameters ..
  2472.       REAL               ZERO, ONE
  2473.       PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
  2474. *     .. Scalar Arguments ..
  2475.       REAL               ALPHA, BETA, EPS, ERR
  2476.       INTEGER            KK, LDA, LDB, LDC, LDCC, M, N, NOUT
  2477.       LOGICAL            FATAL, MV
  2478.       CHARACTER*1        TRANSA, TRANSB
  2479. *     .. Array Arguments ..
  2480.       REAL               A( LDA, * ), B( LDB, * ), C( LDC, * ),
  2481.      $                   CC( LDCC, * ), CT( * ), G( * )
  2482. *     .. Local Scalars ..
  2483.       REAL               ERRI
  2484.       INTEGER            I, J, K
  2485.       LOGICAL            TRANA, TRANB
  2486. *     .. Intrinsic Functions ..
  2487.       INTRINSIC          ABS, MAX, SQRT
  2488. *     .. Executable Statements ..
  2489.       TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
  2490.       TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
  2491. *
  2492. *     Compute expected result, one column at a time, in CT using data
  2493. *     in A, B and C.
  2494. *     Compute gauges in G.
  2495. *
  2496.       DO 120 J = 1, N
  2497. *
  2498.          DO 10 I = 1, M
  2499.             CT( I ) = ZERO
  2500.             G( I ) = ZERO
  2501.    10    CONTINUE
  2502.          IF( .NOT.TRANA.AND..NOT.TRANB )THEN
  2503.             DO 30 K = 1, KK
  2504.                DO 20 I = 1, M
  2505.                   CT( I ) = CT( I ) + A( I, K )*B( K, J )
  2506.                   G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
  2507.    20          CONTINUE
  2508.    30       CONTINUE
  2509.          ELSE IF( TRANA.AND..NOT.TRANB )THEN
  2510.             DO 50 K = 1, KK
  2511.                DO 40 I = 1, M
  2512.                   CT( I ) = CT( I ) + A( K, I )*B( K, J )
  2513.                   G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
  2514.    40          CONTINUE
  2515.    50       CONTINUE
  2516.          ELSE IF( .NOT.TRANA.AND.TRANB )THEN
  2517.             DO 70 K = 1, KK
  2518.                DO 60 I = 1, M
  2519.                   CT( I ) = CT( I ) + A( I, K )*B( J, K )
  2520.                   G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
  2521.    60          CONTINUE
  2522.    70       CONTINUE
  2523.          ELSE IF( TRANA.AND.TRANB )THEN
  2524.             DO 90 K = 1, KK
  2525.                DO 80 I = 1, M
  2526.                   CT( I ) = CT( I ) + A( K, I )*B( J, K )
  2527.                   G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
  2528.    80          CONTINUE
  2529.    90       CONTINUE
  2530.          END IF
  2531.          DO 100 I = 1, M
  2532.             CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
  2533.             G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
  2534.   100    CONTINUE
  2535. *
  2536. *        Compute the error ratio for this result.
  2537. *
  2538.          ERR = ZERO
  2539.          DO 110 I = 1, M
  2540.             ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
  2541.             IF( G( I ).NE.ZERO )
  2542.      $         ERRI = ERRI/G( I )
  2543.             ERR = MAX( ERR, ERRI )
  2544.             IF( ERR*SQRT( EPS ).GE.ONE )
  2545.      $         GO TO 130
  2546.   110    CONTINUE
  2547. *
  2548.   120 CONTINUE
  2549. *
  2550. *     If the loop completes, all results are at least half accurate.
  2551.       GO TO 150
  2552. *
  2553. *     Report fatal error.
  2554. *
  2555.   130 FATAL = .TRUE.
  2556.       WRITE( NOUT, FMT = 9999 )
  2557.       DO 140 I = 1, M
  2558.          IF( MV )THEN
  2559.             WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
  2560.          ELSE
  2561.             WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
  2562.          END IF
  2563.   140 CONTINUE
  2564.       IF( N.GT.1 )
  2565.      $   WRITE( NOUT, FMT = 9997 )J
  2566. *
  2567.   150 CONTINUE
  2568.       RETURN
  2569. *
  2570.  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
  2571.      $      'F ACCURATE *******', /'           EXPECTED RESULT   COMPU',
  2572.      $      'TED RESULT' )
  2573.  9998 FORMAT( 1X, I7, 2G18.6 )
  2574.  9997 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
  2575. *
  2576. *     End of SMMCH.
  2577. *
  2578.       END
  2579.       LOGICAL FUNCTION LSE( RI, RJ, LR )
  2580. *
  2581. *  Tests if two arrays are identical.
  2582. *
  2583. *  Auxiliary routine for test program for Level 3 Blas.
  2584. *
  2585. *  -- Written on 8-February-1989.
  2586. *     Jack Dongarra, Argonne National Laboratory.
  2587. *     Iain Duff, AERE Harwell.
  2588. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  2589. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  2590. *
  2591. *     .. Scalar Arguments ..
  2592.       INTEGER            LR
  2593. *     .. Array Arguments ..
  2594.       REAL               RI( * ), RJ( * )
  2595. *     .. Local Scalars ..
  2596.       INTEGER            I
  2597. *     .. Executable Statements ..
  2598.       DO 10 I = 1, LR
  2599.          IF( RI( I ).NE.RJ( I ) )
  2600.      $      GO TO 20
  2601.    10 CONTINUE
  2602.       LSE = .TRUE.
  2603.       GO TO 30
  2604.    20 CONTINUE
  2605.       LSE = .FALSE.
  2606.    30 RETURN
  2607. *
  2608. *     End of LSE.
  2609. *
  2610.       END
  2611.       LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
  2612. *
  2613. *  Tests if selected elements in two arrays are equal.
  2614. *
  2615. *  TYPE is 'GE' or 'SY'.
  2616. *
  2617. *  Auxiliary routine for test program for Level 3 Blas.
  2618. *
  2619. *  -- Written on 8-February-1989.
  2620. *     Jack Dongarra, Argonne National Laboratory.
  2621. *     Iain Duff, AERE Harwell.
  2622. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  2623. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  2624. *
  2625. *     .. Scalar Arguments ..
  2626.       INTEGER            LDA, M, N
  2627.       CHARACTER*1        UPLO
  2628.       CHARACTER*2        TYPE
  2629. *     .. Array Arguments ..
  2630.       REAL               AA( LDA, * ), AS( LDA, * )
  2631. *     .. Local Scalars ..
  2632.       INTEGER            I, IBEG, IEND, J
  2633.       LOGICAL            UPPER
  2634. *     .. Executable Statements ..
  2635.       UPPER = UPLO.EQ.'U'
  2636.       IF( TYPE.EQ.'GE' )THEN
  2637.          DO 20 J = 1, N
  2638.             DO 10 I = M + 1, LDA
  2639.                IF( AA( I, J ).NE.AS( I, J ) )
  2640.      $            GO TO 70
  2641.    10       CONTINUE
  2642.    20    CONTINUE
  2643.       ELSE IF( TYPE.EQ.'SY' )THEN
  2644.          DO 50 J = 1, N
  2645.             IF( UPPER )THEN
  2646.                IBEG = 1
  2647.                IEND = J
  2648.             ELSE
  2649.                IBEG = J
  2650.                IEND = N
  2651.             END IF
  2652.             DO 30 I = 1, IBEG - 1
  2653.                IF( AA( I, J ).NE.AS( I, J ) )
  2654.      $            GO TO 70
  2655.    30       CONTINUE
  2656.             DO 40 I = IEND + 1, LDA
  2657.                IF( AA( I, J ).NE.AS( I, J ) )
  2658.      $            GO TO 70
  2659.    40       CONTINUE
  2660.    50    CONTINUE
  2661.       END IF
  2662. *
  2663.    60 CONTINUE
  2664.       LSERES = .TRUE.
  2665.       GO TO 80
  2666.    70 CONTINUE
  2667.       LSERES = .FALSE.
  2668.    80 RETURN
  2669. *
  2670. *     End of LSERES.
  2671. *
  2672.       END
  2673.       REAL FUNCTION SBEG( RESET )
  2674. *
  2675. *  Generates random numbers uniformly distributed between -0.5 and 0.5.
  2676. *
  2677. *  Auxiliary routine for test program for Level 3 Blas.
  2678. *
  2679. *  -- Written on 8-February-1989.
  2680. *     Jack Dongarra, Argonne National Laboratory.
  2681. *     Iain Duff, AERE Harwell.
  2682. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  2683. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  2684. *
  2685. *     .. Scalar Arguments ..
  2686.       LOGICAL            RESET
  2687. *     .. Local Scalars ..
  2688.       INTEGER            I, IC, MI
  2689. *     .. Save statement ..
  2690.       SAVE               I, IC, MI
  2691. *     .. Executable Statements ..
  2692.       IF( RESET )THEN
  2693. *        Initialize local variables.
  2694.          MI = 891
  2695.          I = 7
  2696.          IC = 0
  2697.          RESET = .FALSE.
  2698.       END IF
  2699. *
  2700. *     The sequence of values of I is bounded between 1 and 999.
  2701. *     If initial I = 1,2,3,6,7 or 9, the period will be 50.
  2702. *     If initial I = 4 or 8, the period will be 25.
  2703. *     If initial I = 5, the period will be 10.
  2704. *     IC is used to break up the period by skipping 1 value of I in 6.
  2705. *
  2706.       IC = IC + 1
  2707.    10 I = I*MI
  2708.       I = I - 1000*( I/1000 )
  2709.       IF( IC.GE.5 )THEN
  2710.          IC = 0
  2711.          GO TO 10
  2712.       END IF
  2713.       SBEG = ( I - 500 )/1001.0
  2714.       RETURN
  2715. *
  2716. *     End of SBEG.
  2717. *
  2718.       END
  2719.       REAL FUNCTION SDIFF( X, Y )
  2720. *
  2721. *  Auxiliary routine for test program for Level 3 Blas.
  2722. *
  2723. *  -- Written on 8-February-1989.
  2724. *     Jack Dongarra, Argonne National Laboratory.
  2725. *     Iain Duff, AERE Harwell.
  2726. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  2727. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  2728. *
  2729. *     .. Scalar Arguments ..
  2730.       REAL               X, Y
  2731. *     .. Executable Statements ..
  2732.       SDIFF = X - Y
  2733.       RETURN
  2734. *
  2735. *     End of SDIFF.
  2736. *
  2737.       END
  2738.       SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
  2739. *
  2740. *  Tests whether XERBLA has detected an error when it should.
  2741. *
  2742. *  Auxiliary routine for test program for Level 3 Blas.
  2743. *
  2744. *  -- Written on 8-February-1989.
  2745. *     Jack Dongarra, Argonne National Laboratory.
  2746. *     Iain Duff, AERE Harwell.
  2747. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  2748. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  2749. *
  2750. *     .. Scalar Arguments ..
  2751.       INTEGER            INFOT, NOUT
  2752.       LOGICAL            LERR, OK
  2753.       CHARACTER*6        SRNAMT
  2754. *     .. Executable Statements ..
  2755.       IF( .NOT.LERR )THEN
  2756.          WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
  2757.          OK = .FALSE.
  2758.       END IF
  2759.       LERR = .FALSE.
  2760.       RETURN
  2761. *
  2762.  9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
  2763.      $      'ETECTED BY ', A6, ' *****' )
  2764. *
  2765. *     End of CHKXER.
  2766. *
  2767.       END
  2768.       SUBROUTINE XERBLA( SRNAME, INFO )
  2769. *
  2770. *  This is a special version of XERBLA to be used only as part of
  2771. *  the test program for testing error exits from the Level 3 BLAS
  2772. *  routines.
  2773. *
  2774. *  XERBLA  is an error handler for the Level 3 BLAS routines.
  2775. *
  2776. *  It is called by the Level 3 BLAS routines if an input parameter is
  2777. *  invalid.
  2778. *
  2779. *  Auxiliary routine for test program for Level 3 Blas.
  2780. *
  2781. *  -- Written on 8-February-1989.
  2782. *     Jack Dongarra, Argonne National Laboratory.
  2783. *     Iain Duff, AERE Harwell.
  2784. *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
  2785. *     Sven Hammarling, Numerical Algorithms Group Ltd.
  2786. *
  2787. *     .. Scalar Arguments ..
  2788.       INTEGER            INFO
  2789.       CHARACTER*6        SRNAME
  2790. *     .. Scalars in Common ..
  2791.       INTEGER            INFOT, NOUT
  2792.       LOGICAL            LERR, OK
  2793.       CHARACTER*6        SRNAMT
  2794. *     .. Common blocks ..
  2795.       COMMON             /INFOC/INFOT, NOUT, OK, LERR
  2796.       COMMON             /SRNAMC/SRNAMT
  2797. *     .. Executable Statements ..
  2798.       LERR = .TRUE.
  2799.       IF( INFO.NE.INFOT )THEN
  2800.          IF( INFOT.NE.0 )THEN
  2801.             WRITE( NOUT, FMT = 9999 )INFO, INFOT
  2802.          ELSE
  2803.             WRITE( NOUT, FMT = 9997 )INFO
  2804.          END IF
  2805.          OK = .FALSE.
  2806.       END IF
  2807.       IF( SRNAME.NE.SRNAMT )THEN
  2808.          WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
  2809.          OK = .FALSE.
  2810.       END IF
  2811.       RETURN
  2812. *
  2813.  9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
  2814.      $      ' OF ', I2, ' *******' )
  2815.  9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
  2816.      $      'AD OF ', A6, ' *******' )
  2817.  9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
  2818.      $      ' *******' )
  2819. *
  2820. *     End of XERBLA
  2821. *
  2822.       END
  2823.  
  2824.