test/dblat3.f

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