test/sblat3.f

   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