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