LAPACK: BLAS/TESTING/sblat3.f Source File

Go to the documentation of this file.
00001       PROGRAM SBLAT3
00002 *
00003 *  Test program for the REAL             Level 3 Blas.
00004 *
00005 *  The program must be driven by a short data file. The first 14 records
00006 *  of the file are read using list-directed input, the last 6 records
00007 *  are read using the format ( A6, L2 ). An annotated example of a data
00008 *  file can be obtained by deleting the first 3 characters from the
00009 *  following 20 lines:
00010 *  'sblat3.out'      NAME OF SUMMARY OUTPUT FILE
00011 *  6                 UNIT NUMBER OF SUMMARY FILE
00012 *  'SBLAT3.SNAP'     NAME OF SNAPSHOT OUTPUT FILE
00013 *  -1                UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
00014 *  F        LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
00015 *  F        LOGICAL FLAG, T TO STOP ON FAILURES.
00016 *  T        LOGICAL FLAG, T TO TEST ERROR EXITS.
00017 *  16.0     THRESHOLD VALUE OF TEST RATIO
00018 *  6                 NUMBER OF VALUES OF N
00019 *  0 1 2 3 5 9       VALUES OF N
00020 *  3                 NUMBER OF VALUES OF ALPHA
00021 *  0.0 1.0 0.7       VALUES OF ALPHA
00022 *  3                 NUMBER OF VALUES OF BETA
00023 *  0.0 1.0 1.3       VALUES OF BETA
00024 *  SGEMM  T PUT F FOR NO TEST. SAME COLUMNS.
00025 *  SSYMM  T PUT F FOR NO TEST. SAME COLUMNS.
00026 *  STRMM  T PUT F FOR NO TEST. SAME COLUMNS.
00027 *  STRSM  T PUT F FOR NO TEST. SAME COLUMNS.
00028 *  SSYRK  T PUT F FOR NO TEST. SAME COLUMNS.
00029 *  SSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
00030 *
00031 *  See:
00032 *
00033 *     Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
00034 *     A Set of Level 3 Basic Linear Algebra Subprograms.
00035 *
00036 *     Technical Memorandum No.88 (Revision 1), Mathematics and
00037 *     Computer Science Division, Argonne National Laboratory, 9700
00038 *     South Cass Avenue, Argonne, Illinois 60439, US.
00039 *
00040 *  -- Written on 8-February-1989.
00041 *     Jack Dongarra, Argonne National Laboratory.
00042 *     Iain Duff, AERE Harwell.
00043 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
00044 *     Sven Hammarling, Numerical Algorithms Group Ltd.
00045 *
00046 *     10-9-00:  Change STATUS='NEW' to 'UNKNOWN' so that the testers
00047 *               can be run multiple times without deleting generated
00048 *               output files (susan)
00049 *
00050 *     .. Parameters ..
00051       INTEGER            NIN
00052       PARAMETER          ( NIN = 5 )
00053       INTEGER            NSUBS
00054       PARAMETER          ( NSUBS = 6 )
00055       REAL               ZERO, HALF, ONE
00056       PARAMETER          ( ZERO = 0.0, HALF = 0.5, ONE = 1.0 )
00057       INTEGER            NMAX
00058       PARAMETER          ( NMAX = 65 )
00059       INTEGER            NIDMAX, NALMAX, NBEMAX
00060       PARAMETER          ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
00061 *     .. Local Scalars ..
00062       REAL               EPS, ERR, THRESH
00063       INTEGER            I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
00064       LOGICAL            FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
00065      $                   TSTERR
00066       CHARACTER*1        TRANSA, TRANSB
00067       CHARACTER*6        SNAMET
00068       CHARACTER*32       SNAPS, SUMMRY
00069 *     .. Local Arrays ..
00070       REAL               AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
00071      $                   ALF( NALMAX ), AS( NMAX*NMAX ),
00072      $                   BB( NMAX*NMAX ), BET( NBEMAX ),
00073      $                   BS( NMAX*NMAX ), C( NMAX, NMAX ),
00074      $                   CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
00075      $                   G( NMAX ), W( 2*NMAX )
00076       INTEGER            IDIM( NIDMAX )
00077       LOGICAL            LTEST( NSUBS )
00078       CHARACTER*6        SNAMES( NSUBS )
00079 *     .. External Functions ..
00080       REAL               SDIFF
00081       LOGICAL            LSE
00082       EXTERNAL           SDIFF, LSE
00083 *     .. External Subroutines ..
00084       EXTERNAL           SCHK1, SCHK2, SCHK3, SCHK4, SCHK5, SCHKE, SMMCH
00085 *     .. Intrinsic Functions ..
00086       INTRINSIC          MAX, MIN
00087 *     .. Scalars in Common ..
00088       INTEGER            INFOT, NOUTC
00089       LOGICAL            LERR, OK
00090       CHARACTER*6        SRNAMT
00091 *     .. Common blocks ..
00092       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
00093       COMMON             /SRNAMC/SRNAMT
00094 *     .. Data statements ..
00095       DATA               SNAMES/'SGEMM ', 'SSYMM ', 'STRMM ', 'STRSM ',
00096      $                   'SSYRK ', 'SSYR2K'/
00097 *     .. Executable Statements ..
00098 *
00099 *     Read name and unit number for summary output file and open file.
00100 *
00101       READ( NIN, FMT = * )SUMMRY
00102       READ( NIN, FMT = * )NOUT
00103       OPEN( NOUT, FILE = SUMMRY )
00104       NOUTC = NOUT
00105 *
00106 *     Read name and unit number for snapshot output file and open file.
00107 *
00108       READ( NIN, FMT = * )SNAPS
00109       READ( NIN, FMT = * )NTRA
00110       TRACE = NTRA.GE.0
00111       IF( TRACE )THEN
00112          OPEN( NTRA, FILE = SNAPS )
00113       END IF
00114 *     Read the flag that directs rewinding of the snapshot file.
00115       READ( NIN, FMT = * )REWI
00116       REWI = REWI.AND.TRACE
00117 *     Read the flag that directs stopping on any failure.
00118       READ( NIN, FMT = * )SFATAL
00119 *     Read the flag that indicates whether error exits are to be tested.
00120       READ( NIN, FMT = * )TSTERR
00121 *     Read the threshold value of the test ratio
00122       READ( NIN, FMT = * )THRESH
00123 *
00124 *     Read and check the parameter values for the tests.
00125 *
00126 *     Values of N
00127       READ( NIN, FMT = * )NIDIM
00128       IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
00129          WRITE( NOUT, FMT = 9997 )'N', NIDMAX
00130          GO TO 220
00131       END IF
00132       READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
00133       DO 10 I = 1, NIDIM
00134          IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
00135             WRITE( NOUT, FMT = 9996 )NMAX
00136             GO TO 220
00137          END IF
00138    10 CONTINUE
00139 *     Values of ALPHA
00140       READ( NIN, FMT = * )NALF
00141       IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
00142          WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
00143          GO TO 220
00144       END IF
00145       READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
00146 *     Values of BETA
00147       READ( NIN, FMT = * )NBET
00148       IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
00149          WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
00150          GO TO 220
00151       END IF
00152       READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
00153 *
00154 *     Report values of parameters.
00155 *
00156       WRITE( NOUT, FMT = 9995 )
00157       WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
00158       WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
00159       WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
00160       IF( .NOT.TSTERR )THEN
00161          WRITE( NOUT, FMT = * )
00162          WRITE( NOUT, FMT = 9984 )
00163       END IF
00164       WRITE( NOUT, FMT = * )
00165       WRITE( NOUT, FMT = 9999 )THRESH
00166       WRITE( NOUT, FMT = * )
00167 *
00168 *     Read names of subroutines and flags which indicate
00169 *     whether they are to be tested.
00170 *
00171       DO 20 I = 1, NSUBS
00172          LTEST( I ) = .FALSE.
00173    20 CONTINUE
00174    30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
00175       DO 40 I = 1, NSUBS
00176          IF( SNAMET.EQ.SNAMES( I ) )
00177      $      GO TO 50
00178    40 CONTINUE
00179       WRITE( NOUT, FMT = 9990 )SNAMET
00180       STOP
00181    50 LTEST( I ) = LTESTT
00182       GO TO 30
00183 *
00184    60 CONTINUE
00185       CLOSE ( NIN )
00186 *
00187 *     Compute EPS (the machine precision).
00188 *
00189       EPS = ONE
00190    70 CONTINUE
00191       IF( SDIFF( ONE + EPS, ONE ).EQ.ZERO )
00192      $   GO TO 80
00193       EPS = HALF*EPS
00194       GO TO 70
00195    80 CONTINUE
00196       EPS = EPS + EPS
00197       WRITE( NOUT, FMT = 9998 )EPS
00198 *
00199 *     Check the reliability of SMMCH using exact data.
00200 *
00201       N = MIN( 32, NMAX )
00202       DO 100 J = 1, N
00203          DO 90 I = 1, N
00204             AB( I, J ) = MAX( I - J + 1, 0 )
00205    90    CONTINUE
00206          AB( J, NMAX + 1 ) = J
00207          AB( 1, NMAX + J ) = J
00208          C( J, 1 ) = ZERO
00209   100 CONTINUE
00210       DO 110 J = 1, N
00211          CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
00212   110 CONTINUE
00213 *     CC holds the exact result. On exit from SMMCH CT holds
00214 *     the result computed by SMMCH.
00215       TRANSA = 'N'
00216       TRANSB = 'N'
00217       CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
00218      $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
00219      $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
00220       SAME = LSE( CC, CT, N )
00221       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
00222          WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
00223          STOP
00224       END IF
00225       TRANSB = 'T'
00226       CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
00227      $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
00228      $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
00229       SAME = LSE( CC, CT, N )
00230       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
00231          WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
00232          STOP
00233       END IF
00234       DO 120 J = 1, N
00235          AB( J, NMAX + 1 ) = N - J + 1
00236          AB( 1, NMAX + J ) = N - J + 1
00237   120 CONTINUE
00238       DO 130 J = 1, N
00239          CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
00240      $                     ( ( J + 1 )*J*( J - 1 ) )/3
00241   130 CONTINUE
00242       TRANSA = 'T'
00243       TRANSB = 'N'
00244       CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
00245      $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
00246      $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
00247       SAME = LSE( CC, CT, N )
00248       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
00249          WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
00250          STOP
00251       END IF
00252       TRANSB = 'T'
00253       CALL SMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
00254      $            AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
00255      $            NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
00256       SAME = LSE( CC, CT, N )
00257       IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
00258          WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
00259          STOP
00260       END IF
00261 *
00262 *     Test each subroutine in turn.
00263 *
00264       DO 200 ISNUM = 1, NSUBS
00265          WRITE( NOUT, FMT = * )
00266          IF( .NOT.LTEST( ISNUM ) )THEN
00267 *           Subprogram is not to be tested.
00268             WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
00269          ELSE
00270             SRNAMT = SNAMES( ISNUM )
00271 *           Test error exits.
00272             IF( TSTERR )THEN
00273                CALL SCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
00274                WRITE( NOUT, FMT = * )
00275             END IF
00276 *           Test computations.
00277             INFOT = 0
00278             OK = .TRUE.
00279             FATAL = .FALSE.
00280             GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
00281 *           Test SGEMM, 01.
00282   140       CALL SCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00283      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
00284      $                  NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
00285      $                  CC, CS, CT, G )
00286             GO TO 190
00287 *           Test SSYMM, 02.
00288   150       CALL SCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00289      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
00290      $                  NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
00291      $                  CC, CS, CT, G )
00292             GO TO 190
00293 *           Test STRMM, 03, STRSM, 04.
00294   160       CALL SCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00295      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
00296      $                  AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
00297             GO TO 190
00298 *           Test SSYRK, 05.
00299   170       CALL SCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00300      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
00301      $                  NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
00302      $                  CC, CS, CT, G )
00303             GO TO 190
00304 *           Test SSYR2K, 06.
00305   180       CALL SCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
00306      $                  REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
00307      $                  NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
00308             GO TO 190
00309 *
00310   190       IF( FATAL.AND.SFATAL )
00311      $         GO TO 210
00312          END IF
00313   200 CONTINUE
00314       WRITE( NOUT, FMT = 9986 )
00315       GO TO 230
00316 *
00317   210 CONTINUE
00318       WRITE( NOUT, FMT = 9985 )
00319       GO TO 230
00320 *
00321   220 CONTINUE
00322       WRITE( NOUT, FMT = 9991 )
00323 *
00324   230 CONTINUE
00325       IF( TRACE )
00326      $   CLOSE ( NTRA )
00327       CLOSE ( NOUT )
00328       STOP
00329 *
00330  9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
00331      $      'S THAN', F8.2 )
00332  9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, E9.1 )
00333  9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
00334      $      'THAN ', I2 )
00335  9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
00336  9995 FORMAT( ' TESTS OF THE REAL             LEVEL 3 BLAS', //' THE F',
00337      $      'OLLOWING PARAMETER VALUES WILL BE USED:' )
00338  9994 FORMAT( '   FOR N              ', 9I6 )
00339  9993 FORMAT( '   FOR ALPHA          ', 7F6.1 )
00340  9992 FORMAT( '   FOR BETA           ', 7F6.1 )
00341  9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
00342      $      /' ******* TESTS ABANDONED *******' )
00343  9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
00344      $      'ESTS ABANDONED *******' )
00345  9989 FORMAT( ' ERROR IN SMMCH -  IN-LINE DOT PRODUCTS ARE BEING EVALU',
00346      $      'ATED WRONGLY.', /' SMMCH WAS CALLED WITH TRANSA = ', A1,
00347      $      ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
00348      $      'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
00349      $      'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
00350      $      '*******' )
00351  9988 FORMAT( A6, L2 )
00352  9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
00353  9986 FORMAT( /' END OF TESTS' )
00354  9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
00355  9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
00356 *
00357 *     End of SBLAT3.
00358 *
00359       END
00360       SUBROUTINE SCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
00361      $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
00362      $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
00363 *
00364 *  Tests SGEMM.
00365 *
00366 *  Auxiliary routine for test program for Level 3 Blas.
00367 *
00368 *  -- Written on 8-February-1989.
00369 *     Jack Dongarra, Argonne National Laboratory.
00370 *     Iain Duff, AERE Harwell.
00371 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
00372 *     Sven Hammarling, Numerical Algorithms Group Ltd.
00373 *
00374 *     .. Parameters ..
00375       REAL               ZERO
00376       PARAMETER          ( ZERO = 0.0 )
00377 *     .. Scalar Arguments ..
00378       REAL               EPS, THRESH
00379       INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
00380       LOGICAL            FATAL, REWI, TRACE
00381       CHARACTER*6        SNAME
00382 *     .. Array Arguments ..
00383       REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
00384      $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
00385      $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
00386      $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
00387      $                   CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
00388       INTEGER            IDIM( NIDIM )
00389 *     .. Local Scalars ..
00390       REAL               ALPHA, ALS, BETA, BLS, ERR, ERRMAX
00391       INTEGER            I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
00392      $                   LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
00393      $                   MA, MB, MS, N, NA, NARGS, NB, NC, NS
00394       LOGICAL            NULL, RESET, SAME, TRANA, TRANB
00395       CHARACTER*1        TRANAS, TRANBS, TRANSA, TRANSB
00396       CHARACTER*3        ICH
00397 *     .. Local Arrays ..
00398       LOGICAL            ISAME( 13 )
00399 *     .. External Functions ..
00400       LOGICAL            LSE, LSERES
00401       EXTERNAL           LSE, LSERES
00402 *     .. External Subroutines ..
00403       EXTERNAL           SGEMM, SMAKE, SMMCH
00404 *     .. Intrinsic Functions ..
00405       INTRINSIC          MAX
00406 *     .. Scalars in Common ..
00407       INTEGER            INFOT, NOUTC
00408       LOGICAL            LERR, OK
00409 *     .. Common blocks ..
00410       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
00411 *     .. Data statements ..
00412       DATA               ICH/'NTC'/
00413 *     .. Executable Statements ..
00414 *
00415       NARGS = 13
00416       NC = 0
00417       RESET = .TRUE.
00418       ERRMAX = ZERO
00419 *
00420       DO 110 IM = 1, NIDIM
00421          M = IDIM( IM )
00422 *
00423          DO 100 IN = 1, NIDIM
00424             N = IDIM( IN )
00425 *           Set LDC to 1 more than minimum value if room.
00426             LDC = M
00427             IF( LDC.LT.NMAX )
00428      $         LDC = LDC + 1
00429 *           Skip tests if not enough room.
00430             IF( LDC.GT.NMAX )
00431      $         GO TO 100
00432             LCC = LDC*N
00433             NULL = N.LE.0.OR.M.LE.0
00434 *
00435             DO 90 IK = 1, NIDIM
00436                K = IDIM( IK )
00437 *
00438                DO 80 ICA = 1, 3
00439                   TRANSA = ICH( ICA: ICA )
00440                   TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
00441 *
00442                   IF( TRANA )THEN
00443                      MA = K
00444                      NA = M
00445                   ELSE
00446                      MA = M
00447                      NA = K
00448                   END IF
00449 *                 Set LDA to 1 more than minimum value if room.
00450                   LDA = MA
00451                   IF( LDA.LT.NMAX )
00452      $               LDA = LDA + 1
00453 *                 Skip tests if not enough room.
00454                   IF( LDA.GT.NMAX )
00455      $               GO TO 80
00456                   LAA = LDA*NA
00457 *
00458 *                 Generate the matrix A.
00459 *
00460                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
00461      $                        RESET, ZERO )
00462 *
00463                   DO 70 ICB = 1, 3
00464                      TRANSB = ICH( ICB: ICB )
00465                      TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
00466 *
00467                      IF( TRANB )THEN
00468                         MB = N
00469                         NB = K
00470                      ELSE
00471                         MB = K
00472                         NB = N
00473                      END IF
00474 *                    Set LDB to 1 more than minimum value if room.
00475                      LDB = MB
00476                      IF( LDB.LT.NMAX )
00477      $                  LDB = LDB + 1
00478 *                    Skip tests if not enough room.
00479                      IF( LDB.GT.NMAX )
00480      $                  GO TO 70
00481                      LBB = LDB*NB
00482 *
00483 *                    Generate the matrix B.
00484 *
00485                      CALL SMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
00486      $                           LDB, RESET, ZERO )
00487 *
00488                      DO 60 IA = 1, NALF
00489                         ALPHA = ALF( IA )
00490 *
00491                         DO 50 IB = 1, NBET
00492                            BETA = BET( IB )
00493 *
00494 *                          Generate the matrix C.
00495 *
00496                            CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
00497      $                                 CC, LDC, RESET, ZERO )
00498 *
00499                            NC = NC + 1
00500 *
00501 *                          Save every datum before calling the
00502 *                          subroutine.
00503 *
00504                            TRANAS = TRANSA
00505                            TRANBS = TRANSB
00506                            MS = M
00507                            NS = N
00508                            KS = K
00509                            ALS = ALPHA
00510                            DO 10 I = 1, LAA
00511                               AS( I ) = AA( I )
00512    10                      CONTINUE
00513                            LDAS = LDA
00514                            DO 20 I = 1, LBB
00515                               BS( I ) = BB( I )
00516    20                      CONTINUE
00517                            LDBS = LDB
00518                            BLS = BETA
00519                            DO 30 I = 1, LCC
00520                               CS( I ) = CC( I )
00521    30                      CONTINUE
00522                            LDCS = LDC
00523 *
00524 *                          Call the subroutine.
00525 *
00526                            IF( TRACE )
00527      $                        WRITE( NTRA, FMT = 9995 )NC, SNAME,
00528      $                        TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
00529      $                        BETA, LDC
00530                            IF( REWI )
00531      $                        REWIND NTRA
00532                            CALL SGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
00533      $                                 AA, LDA, BB, LDB, BETA, CC, LDC )
00534 *
00535 *                          Check if error-exit was taken incorrectly.
00536 *
00537                            IF( .NOT.OK )THEN
00538                               WRITE( NOUT, FMT = 9994 )
00539                               FATAL = .TRUE.
00540                               GO TO 120
00541                            END IF
00542 *
00543 *                          See what data changed inside subroutines.
00544 *
00545                            ISAME( 1 ) = TRANSA.EQ.TRANAS
00546                            ISAME( 2 ) = TRANSB.EQ.TRANBS
00547                            ISAME( 3 ) = MS.EQ.M
00548                            ISAME( 4 ) = NS.EQ.N
00549                            ISAME( 5 ) = KS.EQ.K
00550                            ISAME( 6 ) = ALS.EQ.ALPHA
00551                            ISAME( 7 ) = LSE( AS, AA, LAA )
00552                            ISAME( 8 ) = LDAS.EQ.LDA
00553                            ISAME( 9 ) = LSE( BS, BB, LBB )
00554                            ISAME( 10 ) = LDBS.EQ.LDB
00555                            ISAME( 11 ) = BLS.EQ.BETA
00556                            IF( NULL )THEN
00557                               ISAME( 12 ) = LSE( CS, CC, LCC )
00558                            ELSE
00559                               ISAME( 12 ) = LSERES( 'GE', ' ', M, N, CS,
00560      $                                      CC, LDC )
00561                            END IF
00562                            ISAME( 13 ) = LDCS.EQ.LDC
00563 *
00564 *                          If data was incorrectly changed, report
00565 *                          and return.
00566 *
00567                            SAME = .TRUE.
00568                            DO 40 I = 1, NARGS
00569                               SAME = SAME.AND.ISAME( I )
00570                               IF( .NOT.ISAME( I ) )
00571      $                           WRITE( NOUT, FMT = 9998 )I
00572    40                      CONTINUE
00573                            IF( .NOT.SAME )THEN
00574                               FATAL = .TRUE.
00575                               GO TO 120
00576                            END IF
00577 *
00578                            IF( .NOT.NULL )THEN
00579 *
00580 *                             Check the result.
00581 *
00582                               CALL SMMCH( TRANSA, TRANSB, M, N, K,
00583      $                                    ALPHA, A, NMAX, B, NMAX, BETA,
00584      $                                    C, NMAX, CT, G, CC, LDC, EPS,
00585      $                                    ERR, FATAL, NOUT, .TRUE. )
00586                               ERRMAX = MAX( ERRMAX, ERR )
00587 *                             If got really bad answer, report and
00588 *                             return.
00589                               IF( FATAL )
00590      $                           GO TO 120
00591                            END IF
00592 *
00593    50                   CONTINUE
00594 *
00595    60                CONTINUE
00596 *
00597    70             CONTINUE
00598 *
00599    80          CONTINUE
00600 *
00601    90       CONTINUE
00602 *
00603   100    CONTINUE
00604 *
00605   110 CONTINUE
00606 *
00607 *     Report result.
00608 *
00609       IF( ERRMAX.LT.THRESH )THEN
00610          WRITE( NOUT, FMT = 9999 )SNAME, NC
00611       ELSE
00612          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
00613       END IF
00614       GO TO 130
00615 *
00616   120 CONTINUE
00617       WRITE( NOUT, FMT = 9996 )SNAME
00618       WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
00619      $   ALPHA, LDA, LDB, BETA, LDC
00620 *
00621   130 CONTINUE
00622       RETURN
00623 *
00624  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
00625      $      'S)' )
00626  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
00627      $      'ANGED INCORRECTLY *******' )
00628  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
00629      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
00630      $      ' - SUSPECT *******' )
00631  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
00632  9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
00633      $      3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
00634      $      'C,', I3, ').' )
00635  9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
00636      $      '******' )
00637 *
00638 *     End of SCHK1.
00639 *
00640       END
00641       SUBROUTINE SCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
00642      $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
00643      $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
00644 *
00645 *  Tests SSYMM.
00646 *
00647 *  Auxiliary routine for test program for Level 3 Blas.
00648 *
00649 *  -- Written on 8-February-1989.
00650 *     Jack Dongarra, Argonne National Laboratory.
00651 *     Iain Duff, AERE Harwell.
00652 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
00653 *     Sven Hammarling, Numerical Algorithms Group Ltd.
00654 *
00655 *     .. Parameters ..
00656       REAL               ZERO
00657       PARAMETER          ( ZERO = 0.0 )
00658 *     .. Scalar Arguments ..
00659       REAL               EPS, THRESH
00660       INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
00661       LOGICAL            FATAL, REWI, TRACE
00662       CHARACTER*6        SNAME
00663 *     .. Array Arguments ..
00664       REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
00665      $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
00666      $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
00667      $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
00668      $                   CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
00669       INTEGER            IDIM( NIDIM )
00670 *     .. Local Scalars ..
00671       REAL               ALPHA, ALS, BETA, BLS, ERR, ERRMAX
00672       INTEGER            I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
00673      $                   LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
00674      $                   NARGS, NC, NS
00675       LOGICAL            LEFT, NULL, RESET, SAME
00676       CHARACTER*1        SIDE, SIDES, UPLO, UPLOS
00677       CHARACTER*2        ICHS, ICHU
00678 *     .. Local Arrays ..
00679       LOGICAL            ISAME( 13 )
00680 *     .. External Functions ..
00681       LOGICAL            LSE, LSERES
00682       EXTERNAL           LSE, LSERES
00683 *     .. External Subroutines ..
00684       EXTERNAL           SMAKE, SMMCH, SSYMM
00685 *     .. Intrinsic Functions ..
00686       INTRINSIC          MAX
00687 *     .. Scalars in Common ..
00688       INTEGER            INFOT, NOUTC
00689       LOGICAL            LERR, OK
00690 *     .. Common blocks ..
00691       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
00692 *     .. Data statements ..
00693       DATA               ICHS/'LR'/, ICHU/'UL'/
00694 *     .. Executable Statements ..
00695 *
00696       NARGS = 12
00697       NC = 0
00698       RESET = .TRUE.
00699       ERRMAX = ZERO
00700 *
00701       DO 100 IM = 1, NIDIM
00702          M = IDIM( IM )
00703 *
00704          DO 90 IN = 1, NIDIM
00705             N = IDIM( IN )
00706 *           Set LDC to 1 more than minimum value if room.
00707             LDC = M
00708             IF( LDC.LT.NMAX )
00709      $         LDC = LDC + 1
00710 *           Skip tests if not enough room.
00711             IF( LDC.GT.NMAX )
00712      $         GO TO 90
00713             LCC = LDC*N
00714             NULL = N.LE.0.OR.M.LE.0
00715 *
00716 *           Set LDB to 1 more than minimum value if room.
00717             LDB = M
00718             IF( LDB.LT.NMAX )
00719      $         LDB = LDB + 1
00720 *           Skip tests if not enough room.
00721             IF( LDB.GT.NMAX )
00722      $         GO TO 90
00723             LBB = LDB*N
00724 *
00725 *           Generate the matrix B.
00726 *
00727             CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
00728      $                  ZERO )
00729 *
00730             DO 80 ICS = 1, 2
00731                SIDE = ICHS( ICS: ICS )
00732                LEFT = SIDE.EQ.'L'
00733 *
00734                IF( LEFT )THEN
00735                   NA = M
00736                ELSE
00737                   NA = N
00738                END IF
00739 *              Set LDA to 1 more than minimum value if room.
00740                LDA = NA
00741                IF( LDA.LT.NMAX )
00742      $            LDA = LDA + 1
00743 *              Skip tests if not enough room.
00744                IF( LDA.GT.NMAX )
00745      $            GO TO 80
00746                LAA = LDA*NA
00747 *
00748                DO 70 ICU = 1, 2
00749                   UPLO = ICHU( ICU: ICU )
00750 *
00751 *                 Generate the symmetric matrix A.
00752 *
00753                   CALL SMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA,
00754      $                        RESET, ZERO )
00755 *
00756                   DO 60 IA = 1, NALF
00757                      ALPHA = ALF( IA )
00758 *
00759                      DO 50 IB = 1, NBET
00760                         BETA = BET( IB )
00761 *
00762 *                       Generate the matrix C.
00763 *
00764                         CALL SMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
00765      $                              LDC, RESET, ZERO )
00766 *
00767                         NC = NC + 1
00768 *
00769 *                       Save every datum before calling the
00770 *                       subroutine.
00771 *
00772                         SIDES = SIDE
00773                         UPLOS = UPLO
00774                         MS = M
00775                         NS = N
00776                         ALS = ALPHA
00777                         DO 10 I = 1, LAA
00778                            AS( I ) = AA( I )
00779    10                   CONTINUE
00780                         LDAS = LDA
00781                         DO 20 I = 1, LBB
00782                            BS( I ) = BB( I )
00783    20                   CONTINUE
00784                         LDBS = LDB
00785                         BLS = BETA
00786                         DO 30 I = 1, LCC
00787                            CS( I ) = CC( I )
00788    30                   CONTINUE
00789                         LDCS = LDC
00790 *
00791 *                       Call the subroutine.
00792 *
00793                         IF( TRACE )
00794      $                     WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
00795      $                     UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
00796                         IF( REWI )
00797      $                     REWIND NTRA
00798                         CALL SSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
00799      $                              BB, LDB, BETA, CC, LDC )
00800 *
00801 *                       Check if error-exit was taken incorrectly.
00802 *
00803                         IF( .NOT.OK )THEN
00804                            WRITE( NOUT, FMT = 9994 )
00805                            FATAL = .TRUE.
00806                            GO TO 110
00807                         END IF
00808 *
00809 *                       See what data changed inside subroutines.
00810 *
00811                         ISAME( 1 ) = SIDES.EQ.SIDE
00812                         ISAME( 2 ) = UPLOS.EQ.UPLO
00813                         ISAME( 3 ) = MS.EQ.M
00814                         ISAME( 4 ) = NS.EQ.N
00815                         ISAME( 5 ) = ALS.EQ.ALPHA
00816                         ISAME( 6 ) = LSE( AS, AA, LAA )
00817                         ISAME( 7 ) = LDAS.EQ.LDA
00818                         ISAME( 8 ) = LSE( BS, BB, LBB )
00819                         ISAME( 9 ) = LDBS.EQ.LDB
00820                         ISAME( 10 ) = BLS.EQ.BETA
00821                         IF( NULL )THEN
00822                            ISAME( 11 ) = LSE( CS, CC, LCC )
00823                         ELSE
00824                            ISAME( 11 ) = LSERES( 'GE', ' ', M, N, CS,
00825      $                                   CC, LDC )
00826                         END IF
00827                         ISAME( 12 ) = LDCS.EQ.LDC
00828 *
00829 *                       If data was incorrectly changed, report and
00830 *                       return.
00831 *
00832                         SAME = .TRUE.
00833                         DO 40 I = 1, NARGS
00834                            SAME = SAME.AND.ISAME( I )
00835                            IF( .NOT.ISAME( I ) )
00836      $                        WRITE( NOUT, FMT = 9998 )I
00837    40                   CONTINUE
00838                         IF( .NOT.SAME )THEN
00839                            FATAL = .TRUE.
00840                            GO TO 110
00841                         END IF
00842 *
00843                         IF( .NOT.NULL )THEN
00844 *
00845 *                          Check the result.
00846 *
00847                            IF( LEFT )THEN
00848                               CALL SMMCH( 'N', 'N', M, N, M, ALPHA, A,
00849      $                                    NMAX, B, NMAX, BETA, C, NMAX,
00850      $                                    CT, G, CC, LDC, EPS, ERR,
00851      $                                    FATAL, NOUT, .TRUE. )
00852                            ELSE
00853                               CALL SMMCH( 'N', 'N', M, N, N, ALPHA, B,
00854      $                                    NMAX, A, NMAX, BETA, C, NMAX,
00855      $                                    CT, G, CC, LDC, EPS, ERR,
00856      $                                    FATAL, NOUT, .TRUE. )
00857                            END IF
00858                            ERRMAX = MAX( ERRMAX, ERR )
00859 *                          If got really bad answer, report and
00860 *                          return.
00861                            IF( FATAL )
00862      $                        GO TO 110
00863                         END IF
00864 *
00865    50                CONTINUE
00866 *
00867    60             CONTINUE
00868 *
00869    70          CONTINUE
00870 *
00871    80       CONTINUE
00872 *
00873    90    CONTINUE
00874 *
00875   100 CONTINUE
00876 *
00877 *     Report result.
00878 *
00879       IF( ERRMAX.LT.THRESH )THEN
00880          WRITE( NOUT, FMT = 9999 )SNAME, NC
00881       ELSE
00882          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
00883       END IF
00884       GO TO 120
00885 *
00886   110 CONTINUE
00887       WRITE( NOUT, FMT = 9996 )SNAME
00888       WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
00889      $   LDB, BETA, LDC
00890 *
00891   120 CONTINUE
00892       RETURN
00893 *
00894  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
00895      $      'S)' )
00896  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
00897      $      'ANGED INCORRECTLY *******' )
00898  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
00899      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
00900      $      ' - SUSPECT *******' )
00901  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
00902  9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
00903      $      F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ')   ',
00904      $      ' .' )
00905  9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
00906      $      '******' )
00907 *
00908 *     End of SCHK2.
00909 *
00910       END
00911       SUBROUTINE SCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
00912      $                  FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
00913      $                  B, BB, BS, CT, G, C )
00914 *
00915 *  Tests STRMM and STRSM.
00916 *
00917 *  Auxiliary routine for test program for Level 3 Blas.
00918 *
00919 *  -- Written on 8-February-1989.
00920 *     Jack Dongarra, Argonne National Laboratory.
00921 *     Iain Duff, AERE Harwell.
00922 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
00923 *     Sven Hammarling, Numerical Algorithms Group Ltd.
00924 *
00925 *     .. Parameters ..
00926       REAL               ZERO, ONE
00927       PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
00928 *     .. Scalar Arguments ..
00929       REAL               EPS, THRESH
00930       INTEGER            NALF, NIDIM, NMAX, NOUT, NTRA
00931       LOGICAL            FATAL, REWI, TRACE
00932       CHARACTER*6        SNAME
00933 *     .. Array Arguments ..
00934       REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
00935      $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
00936      $                   BB( NMAX*NMAX ), BS( NMAX*NMAX ),
00937      $                   C( NMAX, NMAX ), CT( NMAX ), G( NMAX )
00938       INTEGER            IDIM( NIDIM )
00939 *     .. Local Scalars ..
00940       REAL               ALPHA, ALS, ERR, ERRMAX
00941       INTEGER            I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
00942      $                   LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
00943      $                   NS
00944       LOGICAL            LEFT, NULL, RESET, SAME
00945       CHARACTER*1        DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
00946      $                   UPLOS
00947       CHARACTER*2        ICHD, ICHS, ICHU
00948       CHARACTER*3        ICHT
00949 *     .. Local Arrays ..
00950       LOGICAL            ISAME( 13 )
00951 *     .. External Functions ..
00952       LOGICAL            LSE, LSERES
00953       EXTERNAL           LSE, LSERES
00954 *     .. External Subroutines ..
00955       EXTERNAL           SMAKE, SMMCH, STRMM, STRSM
00956 *     .. Intrinsic Functions ..
00957       INTRINSIC          MAX
00958 *     .. Scalars in Common ..
00959       INTEGER            INFOT, NOUTC
00960       LOGICAL            LERR, OK
00961 *     .. Common blocks ..
00962       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
00963 *     .. Data statements ..
00964       DATA               ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
00965 *     .. Executable Statements ..
00966 *
00967       NARGS = 11
00968       NC = 0
00969       RESET = .TRUE.
00970       ERRMAX = ZERO
00971 *     Set up zero matrix for SMMCH.
00972       DO 20 J = 1, NMAX
00973          DO 10 I = 1, NMAX
00974             C( I, J ) = ZERO
00975    10    CONTINUE
00976    20 CONTINUE
00977 *
00978       DO 140 IM = 1, NIDIM
00979          M = IDIM( IM )
00980 *
00981          DO 130 IN = 1, NIDIM
00982             N = IDIM( IN )
00983 *           Set LDB to 1 more than minimum value if room.
00984             LDB = M
00985             IF( LDB.LT.NMAX )
00986      $         LDB = LDB + 1
00987 *           Skip tests if not enough room.
00988             IF( LDB.GT.NMAX )
00989      $         GO TO 130
00990             LBB = LDB*N
00991             NULL = M.LE.0.OR.N.LE.0
00992 *
00993             DO 120 ICS = 1, 2
00994                SIDE = ICHS( ICS: ICS )
00995                LEFT = SIDE.EQ.'L'
00996                IF( LEFT )THEN
00997                   NA = M
00998                ELSE
00999                   NA = N
01000                END IF
01001 *              Set LDA to 1 more than minimum value if room.
01002                LDA = NA
01003                IF( LDA.LT.NMAX )
01004      $            LDA = LDA + 1
01005 *              Skip tests if not enough room.
01006                IF( LDA.GT.NMAX )
01007      $            GO TO 130
01008                LAA = LDA*NA
01009 *
01010                DO 110 ICU = 1, 2
01011                   UPLO = ICHU( ICU: ICU )
01012 *
01013                   DO 100 ICT = 1, 3
01014                      TRANSA = ICHT( ICT: ICT )
01015 *
01016                      DO 90 ICD = 1, 2
01017                         DIAG = ICHD( ICD: ICD )
01018 *
01019                         DO 80 IA = 1, NALF
01020                            ALPHA = ALF( IA )
01021 *
01022 *                          Generate the matrix A.
01023 *
01024                            CALL SMAKE( 'TR', UPLO, DIAG, NA, NA, A,
01025      $                                 NMAX, AA, LDA, RESET, ZERO )
01026 *
01027 *                          Generate the matrix B.
01028 *
01029                            CALL SMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
01030      $                                 BB, LDB, RESET, ZERO )
01031 *
01032                            NC = NC + 1
01033 *
01034 *                          Save every datum before calling the
01035 *                          subroutine.
01036 *
01037                            SIDES = SIDE
01038                            UPLOS = UPLO
01039                            TRANAS = TRANSA
01040                            DIAGS = DIAG
01041                            MS = M
01042                            NS = N
01043                            ALS = ALPHA
01044                            DO 30 I = 1, LAA
01045                               AS( I ) = AA( I )
01046    30                      CONTINUE
01047                            LDAS = LDA
01048                            DO 40 I = 1, LBB
01049                               BS( I ) = BB( I )
01050    40                      CONTINUE
01051                            LDBS = LDB
01052 *
01053 *                          Call the subroutine.
01054 *
01055                            IF( SNAME( 4: 5 ).EQ.'MM' )THEN
01056                               IF( TRACE )
01057      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
01058      $                           SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
01059      $                           LDA, LDB
01060                               IF( REWI )
01061      $                           REWIND NTRA
01062                               CALL STRMM( SIDE, UPLO, TRANSA, DIAG, M,
01063      $                                    N, ALPHA, AA, LDA, BB, LDB )
01064                            ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
01065                               IF( TRACE )
01066      $                           WRITE( NTRA, FMT = 9995 )NC, SNAME,
01067      $                           SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
01068      $                           LDA, LDB
01069                               IF( REWI )
01070      $                           REWIND NTRA
01071                               CALL STRSM( SIDE, UPLO, TRANSA, DIAG, M,
01072      $                                    N, ALPHA, AA, LDA, BB, LDB )
01073                            END IF
01074 *
01075 *                          Check if error-exit was taken incorrectly.
01076 *
01077                            IF( .NOT.OK )THEN
01078                               WRITE( NOUT, FMT = 9994 )
01079                               FATAL = .TRUE.
01080                               GO TO 150
01081                            END IF
01082 *
01083 *                          See what data changed inside subroutines.
01084 *
01085                            ISAME( 1 ) = SIDES.EQ.SIDE
01086                            ISAME( 2 ) = UPLOS.EQ.UPLO
01087                            ISAME( 3 ) = TRANAS.EQ.TRANSA
01088                            ISAME( 4 ) = DIAGS.EQ.DIAG
01089                            ISAME( 5 ) = MS.EQ.M
01090                            ISAME( 6 ) = NS.EQ.N
01091                            ISAME( 7 ) = ALS.EQ.ALPHA
01092                            ISAME( 8 ) = LSE( AS, AA, LAA )
01093                            ISAME( 9 ) = LDAS.EQ.LDA
01094                            IF( NULL )THEN
01095                               ISAME( 10 ) = LSE( BS, BB, LBB )
01096                            ELSE
01097                               ISAME( 10 ) = LSERES( 'GE', ' ', M, N, BS,
01098      $                                      BB, LDB )
01099                            END IF
01100                            ISAME( 11 ) = LDBS.EQ.LDB
01101 *
01102 *                          If data was incorrectly changed, report and
01103 *                          return.
01104 *
01105                            SAME = .TRUE.
01106                            DO 50 I = 1, NARGS
01107                               SAME = SAME.AND.ISAME( I )
01108                               IF( .NOT.ISAME( I ) )
01109      $                           WRITE( NOUT, FMT = 9998 )I
01110    50                      CONTINUE
01111                            IF( .NOT.SAME )THEN
01112                               FATAL = .TRUE.
01113                               GO TO 150
01114                            END IF
01115 *
01116                            IF( .NOT.NULL )THEN
01117                               IF( SNAME( 4: 5 ).EQ.'MM' )THEN
01118 *
01119 *                                Check the result.
01120 *
01121                                  IF( LEFT )THEN
01122                                     CALL SMMCH( TRANSA, 'N', M, N, M,
01123      $                                          ALPHA, A, NMAX, B, NMAX,
01124      $                                          ZERO, C, NMAX, CT, G,
01125      $                                          BB, LDB, EPS, ERR,
01126      $                                          FATAL, NOUT, .TRUE. )
01127                                  ELSE
01128                                     CALL SMMCH( 'N', TRANSA, M, N, N,
01129      $                                          ALPHA, B, NMAX, A, NMAX,
01130      $                                          ZERO, C, NMAX, CT, G,
01131      $                                          BB, LDB, EPS, ERR,
01132      $                                          FATAL, NOUT, .TRUE. )
01133                                  END IF
01134                               ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
01135 *
01136 *                                Compute approximation to original
01137 *                                matrix.
01138 *
01139                                  DO 70 J = 1, N
01140                                     DO 60 I = 1, M
01141                                        C( I, J ) = BB( I + ( J - 1 )*
01142      $                                             LDB )
01143                                        BB( I + ( J - 1 )*LDB ) = ALPHA*
01144      $                                    B( I, J )
01145    60                               CONTINUE
01146    70                            CONTINUE
01147 *
01148                                  IF( LEFT )THEN
01149                                     CALL SMMCH( TRANSA, 'N', M, N, M,
01150      $                                          ONE, A, NMAX, C, NMAX,
01151      $                                          ZERO, B, NMAX, CT, G,
01152      $                                          BB, LDB, EPS, ERR,
01153      $                                          FATAL, NOUT, .FALSE. )
01154                                  ELSE
01155                                     CALL SMMCH( 'N', TRANSA, M, N, N,
01156      $                                          ONE, C, NMAX, A, NMAX,
01157      $                                          ZERO, B, NMAX, CT, G,
01158      $                                          BB, LDB, EPS, ERR,
01159      $                                          FATAL, NOUT, .FALSE. )
01160                                  END IF
01161                               END IF
01162                               ERRMAX = MAX( ERRMAX, ERR )
01163 *                             If got really bad answer, report and
01164 *                             return.
01165                               IF( FATAL )
01166      $                           GO TO 150
01167                            END IF
01168 *
01169    80                   CONTINUE
01170 *
01171    90                CONTINUE
01172 *
01173   100             CONTINUE
01174 *
01175   110          CONTINUE
01176 *
01177   120       CONTINUE
01178 *
01179   130    CONTINUE
01180 *
01181   140 CONTINUE
01182 *
01183 *     Report result.
01184 *
01185       IF( ERRMAX.LT.THRESH )THEN
01186          WRITE( NOUT, FMT = 9999 )SNAME, NC
01187       ELSE
01188          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
01189       END IF
01190       GO TO 160
01191 *
01192   150 CONTINUE
01193       WRITE( NOUT, FMT = 9996 )SNAME
01194       WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
01195      $   N, ALPHA, LDA, LDB
01196 *
01197   160 CONTINUE
01198       RETURN
01199 *
01200  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
01201      $      'S)' )
01202  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
01203      $      'ANGED INCORRECTLY *******' )
01204  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
01205      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
01206      $      ' - SUSPECT *******' )
01207  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
01208  9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
01209      $      F4.1, ', A,', I3, ', B,', I3, ')        .' )
01210  9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
01211      $      '******' )
01212 *
01213 *     End of SCHK3.
01214 *
01215       END
01216       SUBROUTINE SCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
01217      $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
01218      $                  A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
01219 *
01220 *  Tests SSYRK.
01221 *
01222 *  Auxiliary routine for test program for Level 3 Blas.
01223 *
01224 *  -- Written on 8-February-1989.
01225 *     Jack Dongarra, Argonne National Laboratory.
01226 *     Iain Duff, AERE Harwell.
01227 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
01228 *     Sven Hammarling, Numerical Algorithms Group Ltd.
01229 *
01230 *     .. Parameters ..
01231       REAL               ZERO
01232       PARAMETER          ( ZERO = 0.0 )
01233 *     .. Scalar Arguments ..
01234       REAL               EPS, THRESH
01235       INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
01236       LOGICAL            FATAL, REWI, TRACE
01237       CHARACTER*6        SNAME
01238 *     .. Array Arguments ..
01239       REAL               A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
01240      $                   AS( NMAX*NMAX ), B( NMAX, NMAX ),
01241      $                   BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
01242      $                   C( NMAX, NMAX ), CC( NMAX*NMAX ),
01243      $                   CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
01244       INTEGER            IDIM( NIDIM )
01245 *     .. Local Scalars ..
01246       REAL               ALPHA, ALS, BETA, BETS, ERR, ERRMAX
01247       INTEGER            I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
01248      $                   LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
01249      $                   NARGS, NC, NS
01250       LOGICAL            NULL, RESET, SAME, TRAN, UPPER
01251       CHARACTER*1        TRANS, TRANSS, UPLO, UPLOS
01252       CHARACTER*2        ICHU
01253       CHARACTER*3        ICHT
01254 *     .. Local Arrays ..
01255       LOGICAL            ISAME( 13 )
01256 *     .. External Functions ..
01257       LOGICAL            LSE, LSERES
01258       EXTERNAL           LSE, LSERES
01259 *     .. External Subroutines ..
01260       EXTERNAL           SMAKE, SMMCH, SSYRK
01261 *     .. Intrinsic Functions ..
01262       INTRINSIC          MAX
01263 *     .. Scalars in Common ..
01264       INTEGER            INFOT, NOUTC
01265       LOGICAL            LERR, OK
01266 *     .. Common blocks ..
01267       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
01268 *     .. Data statements ..
01269       DATA               ICHT/'NTC'/, ICHU/'UL'/
01270 *     .. Executable Statements ..
01271 *
01272       NARGS = 10
01273       NC = 0
01274       RESET = .TRUE.
01275       ERRMAX = ZERO
01276 *
01277       DO 100 IN = 1, NIDIM
01278          N = IDIM( IN )
01279 *        Set LDC to 1 more than minimum value if room.
01280          LDC = N
01281          IF( LDC.LT.NMAX )
01282      $      LDC = LDC + 1
01283 *        Skip tests if not enough room.
01284          IF( LDC.GT.NMAX )
01285      $      GO TO 100
01286          LCC = LDC*N
01287          NULL = N.LE.0
01288 *
01289          DO 90 IK = 1, NIDIM
01290             K = IDIM( IK )
01291 *
01292             DO 80 ICT = 1, 3
01293                TRANS = ICHT( ICT: ICT )
01294                TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
01295                IF( TRAN )THEN
01296                   MA = K
01297                   NA = N
01298                ELSE
01299                   MA = N
01300                   NA = K
01301                END IF
01302 *              Set LDA to 1 more than minimum value if room.
01303                LDA = MA
01304                IF( LDA.LT.NMAX )
01305      $            LDA = LDA + 1
01306 *              Skip tests if not enough room.
01307                IF( LDA.GT.NMAX )
01308      $            GO TO 80
01309                LAA = LDA*NA
01310 *
01311 *              Generate the matrix A.
01312 *
01313                CALL SMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
01314      $                     RESET, ZERO )
01315 *
01316                DO 70 ICU = 1, 2
01317                   UPLO = ICHU( ICU: ICU )
01318                   UPPER = UPLO.EQ.'U'
01319 *
01320                   DO 60 IA = 1, NALF
01321                      ALPHA = ALF( IA )
01322 *
01323                      DO 50 IB = 1, NBET
01324                         BETA = BET( IB )
01325 *
01326 *                       Generate the matrix C.
01327 *
01328                         CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
01329      $                              LDC, RESET, ZERO )
01330 *
01331                         NC = NC + 1
01332 *
01333 *                       Save every datum before calling the subroutine.
01334 *
01335                         UPLOS = UPLO
01336                         TRANSS = TRANS
01337                         NS = N
01338                         KS = K
01339                         ALS = ALPHA
01340                         DO 10 I = 1, LAA
01341                            AS( I ) = AA( I )
01342    10                   CONTINUE
01343                         LDAS = LDA
01344                         BETS = BETA
01345                         DO 20 I = 1, LCC
01346                            CS( I ) = CC( I )
01347    20                   CONTINUE
01348                         LDCS = LDC
01349 *
01350 *                       Call the subroutine.
01351 *
01352                         IF( TRACE )
01353      $                     WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
01354      $                     TRANS, N, K, ALPHA, LDA, BETA, LDC
01355                         IF( REWI )
01356      $                     REWIND NTRA
01357                         CALL SSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA,
01358      $                              BETA, CC, LDC )
01359 *
01360 *                       Check if error-exit was taken incorrectly.
01361 *
01362                         IF( .NOT.OK )THEN
01363                            WRITE( NOUT, FMT = 9993 )
01364                            FATAL = .TRUE.
01365                            GO TO 120
01366                         END IF
01367 *
01368 *                       See what data changed inside subroutines.
01369 *
01370                         ISAME( 1 ) = UPLOS.EQ.UPLO
01371                         ISAME( 2 ) = TRANSS.EQ.TRANS
01372                         ISAME( 3 ) = NS.EQ.N
01373                         ISAME( 4 ) = KS.EQ.K
01374                         ISAME( 5 ) = ALS.EQ.ALPHA
01375                         ISAME( 6 ) = LSE( AS, AA, LAA )
01376                         ISAME( 7 ) = LDAS.EQ.LDA
01377                         ISAME( 8 ) = BETS.EQ.BETA
01378                         IF( NULL )THEN
01379                            ISAME( 9 ) = LSE( CS, CC, LCC )
01380                         ELSE
01381                            ISAME( 9 ) = LSERES( 'SY', UPLO, N, N, CS,
01382      $                                  CC, LDC )
01383                         END IF
01384                         ISAME( 10 ) = LDCS.EQ.LDC
01385 *
01386 *                       If data was incorrectly changed, report and
01387 *                       return.
01388 *
01389                         SAME = .TRUE.
01390                         DO 30 I = 1, NARGS
01391                            SAME = SAME.AND.ISAME( I )
01392                            IF( .NOT.ISAME( I ) )
01393      $                        WRITE( NOUT, FMT = 9998 )I
01394    30                   CONTINUE
01395                         IF( .NOT.SAME )THEN
01396                            FATAL = .TRUE.
01397                            GO TO 120
01398                         END IF
01399 *
01400                         IF( .NOT.NULL )THEN
01401 *
01402 *                          Check the result column by column.
01403 *
01404                            JC = 1
01405                            DO 40 J = 1, N
01406                               IF( UPPER )THEN
01407                                  JJ = 1
01408                                  LJ = J
01409                               ELSE
01410                                  JJ = J
01411                                  LJ = N - J + 1
01412                               END IF
01413                               IF( TRAN )THEN
01414                                  CALL SMMCH( 'T', 'N', LJ, 1, K, ALPHA,
01415      $                                       A( 1, JJ ), NMAX,
01416      $                                       A( 1, J ), NMAX, BETA,
01417      $                                       C( JJ, J ), NMAX, CT, G,
01418      $                                       CC( JC ), LDC, EPS, ERR,
01419      $                                       FATAL, NOUT, .TRUE. )
01420                               ELSE
01421                                  CALL SMMCH( 'N', 'T', LJ, 1, K, ALPHA,
01422      $                                       A( JJ, 1 ), NMAX,
01423      $                                       A( J, 1 ), NMAX, BETA,
01424      $                                       C( JJ, J ), NMAX, CT, G,
01425      $                                       CC( JC ), LDC, EPS, ERR,
01426      $                                       FATAL, NOUT, .TRUE. )
01427                               END IF
01428                               IF( UPPER )THEN
01429                                  JC = JC + LDC
01430                               ELSE
01431                                  JC = JC + LDC + 1
01432                               END IF
01433                               ERRMAX = MAX( ERRMAX, ERR )
01434 *                             If got really bad answer, report and
01435 *                             return.
01436                               IF( FATAL )
01437      $                           GO TO 110
01438    40                      CONTINUE
01439                         END IF
01440 *
01441    50                CONTINUE
01442 *
01443    60             CONTINUE
01444 *
01445    70          CONTINUE
01446 *
01447    80       CONTINUE
01448 *
01449    90    CONTINUE
01450 *
01451   100 CONTINUE
01452 *
01453 *     Report result.
01454 *
01455       IF( ERRMAX.LT.THRESH )THEN
01456          WRITE( NOUT, FMT = 9999 )SNAME, NC
01457       ELSE
01458          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
01459       END IF
01460       GO TO 130
01461 *
01462   110 CONTINUE
01463       IF( N.GT.1 )
01464      $   WRITE( NOUT, FMT = 9995 )J
01465 *
01466   120 CONTINUE
01467       WRITE( NOUT, FMT = 9996 )SNAME
01468       WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
01469      $   LDA, BETA, LDC
01470 *
01471   130 CONTINUE
01472       RETURN
01473 *
01474  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
01475      $      'S)' )
01476  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
01477      $      'ANGED INCORRECTLY *******' )
01478  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
01479      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
01480      $      ' - SUSPECT *******' )
01481  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
01482  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
01483  9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
01484      $      F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ')           .' )
01485  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
01486      $      '******' )
01487 *
01488 *     End of SCHK4.
01489 *
01490       END
01491       SUBROUTINE SCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
01492      $                  FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
01493      $                  AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
01494 *
01495 *  Tests SSYR2K.
01496 *
01497 *  Auxiliary routine for test program for Level 3 Blas.
01498 *
01499 *  -- Written on 8-February-1989.
01500 *     Jack Dongarra, Argonne National Laboratory.
01501 *     Iain Duff, AERE Harwell.
01502 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
01503 *     Sven Hammarling, Numerical Algorithms Group Ltd.
01504 *
01505 *     .. Parameters ..
01506       REAL               ZERO
01507       PARAMETER          ( ZERO = 0.0 )
01508 *     .. Scalar Arguments ..
01509       REAL               EPS, THRESH
01510       INTEGER            NALF, NBET, NIDIM, NMAX, NOUT, NTRA
01511       LOGICAL            FATAL, REWI, TRACE
01512       CHARACTER*6        SNAME
01513 *     .. Array Arguments ..
01514       REAL               AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
01515      $                   ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
01516      $                   BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
01517      $                   CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
01518      $                   G( NMAX ), W( 2*NMAX )
01519       INTEGER            IDIM( NIDIM )
01520 *     .. Local Scalars ..
01521       REAL               ALPHA, ALS, BETA, BETS, ERR, ERRMAX
01522       INTEGER            I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
01523      $                   K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
01524      $                   LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
01525       LOGICAL            NULL, RESET, SAME, TRAN, UPPER
01526       CHARACTER*1        TRANS, TRANSS, UPLO, UPLOS
01527       CHARACTER*2        ICHU
01528       CHARACTER*3        ICHT
01529 *     .. Local Arrays ..
01530       LOGICAL            ISAME( 13 )
01531 *     .. External Functions ..
01532       LOGICAL            LSE, LSERES
01533       EXTERNAL           LSE, LSERES
01534 *     .. External Subroutines ..
01535       EXTERNAL           SMAKE, SMMCH, SSYR2K
01536 *     .. Intrinsic Functions ..
01537       INTRINSIC          MAX
01538 *     .. Scalars in Common ..
01539       INTEGER            INFOT, NOUTC
01540       LOGICAL            LERR, OK
01541 *     .. Common blocks ..
01542       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
01543 *     .. Data statements ..
01544       DATA               ICHT/'NTC'/, ICHU/'UL'/
01545 *     .. Executable Statements ..
01546 *
01547       NARGS = 12
01548       NC = 0
01549       RESET = .TRUE.
01550       ERRMAX = ZERO
01551 *
01552       DO 130 IN = 1, NIDIM
01553          N = IDIM( IN )
01554 *        Set LDC to 1 more than minimum value if room.
01555          LDC = N
01556          IF( LDC.LT.NMAX )
01557      $      LDC = LDC + 1
01558 *        Skip tests if not enough room.
01559          IF( LDC.GT.NMAX )
01560      $      GO TO 130
01561          LCC = LDC*N
01562          NULL = N.LE.0
01563 *
01564          DO 120 IK = 1, NIDIM
01565             K = IDIM( IK )
01566 *
01567             DO 110 ICT = 1, 3
01568                TRANS = ICHT( ICT: ICT )
01569                TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
01570                IF( TRAN )THEN
01571                   MA = K
01572                   NA = N
01573                ELSE
01574                   MA = N
01575                   NA = K
01576                END IF
01577 *              Set LDA to 1 more than minimum value if room.
01578                LDA = MA
01579                IF( LDA.LT.NMAX )
01580      $            LDA = LDA + 1
01581 *              Skip tests if not enough room.
01582                IF( LDA.GT.NMAX )
01583      $            GO TO 110
01584                LAA = LDA*NA
01585 *
01586 *              Generate the matrix A.
01587 *
01588                IF( TRAN )THEN
01589                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
01590      $                        LDA, RESET, ZERO )
01591                ELSE
01592                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
01593      $                        RESET, ZERO )
01594                END IF
01595 *
01596 *              Generate the matrix B.
01597 *
01598                LDB = LDA
01599                LBB = LAA
01600                IF( TRAN )THEN
01601                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
01602      $                        2*NMAX, BB, LDB, RESET, ZERO )
01603                ELSE
01604                   CALL SMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
01605      $                        NMAX, BB, LDB, RESET, ZERO )
01606                END IF
01607 *
01608                DO 100 ICU = 1, 2
01609                   UPLO = ICHU( ICU: ICU )
01610                   UPPER = UPLO.EQ.'U'
01611 *
01612                   DO 90 IA = 1, NALF
01613                      ALPHA = ALF( IA )
01614 *
01615                      DO 80 IB = 1, NBET
01616                         BETA = BET( IB )
01617 *
01618 *                       Generate the matrix C.
01619 *
01620                         CALL SMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
01621      $                              LDC, RESET, ZERO )
01622 *
01623                         NC = NC + 1
01624 *
01625 *                       Save every datum before calling the subroutine.
01626 *
01627                         UPLOS = UPLO
01628                         TRANSS = TRANS
01629                         NS = N
01630                         KS = K
01631                         ALS = ALPHA
01632                         DO 10 I = 1, LAA
01633                            AS( I ) = AA( I )
01634    10                   CONTINUE
01635                         LDAS = LDA
01636                         DO 20 I = 1, LBB
01637                            BS( I ) = BB( I )
01638    20                   CONTINUE
01639                         LDBS = LDB
01640                         BETS = BETA
01641                         DO 30 I = 1, LCC
01642                            CS( I ) = CC( I )
01643    30                   CONTINUE
01644                         LDCS = LDC
01645 *
01646 *                       Call the subroutine.
01647 *
01648                         IF( TRACE )
01649      $                     WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
01650      $                     TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
01651                         IF( REWI )
01652      $                     REWIND NTRA
01653                         CALL SSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA,
01654      $                               BB, LDB, BETA, CC, LDC )
01655 *
01656 *                       Check if error-exit was taken incorrectly.
01657 *
01658                         IF( .NOT.OK )THEN
01659                            WRITE( NOUT, FMT = 9993 )
01660                            FATAL = .TRUE.
01661                            GO TO 150
01662                         END IF
01663 *
01664 *                       See what data changed inside subroutines.
01665 *
01666                         ISAME( 1 ) = UPLOS.EQ.UPLO
01667                         ISAME( 2 ) = TRANSS.EQ.TRANS
01668                         ISAME( 3 ) = NS.EQ.N
01669                         ISAME( 4 ) = KS.EQ.K
01670                         ISAME( 5 ) = ALS.EQ.ALPHA
01671                         ISAME( 6 ) = LSE( AS, AA, LAA )
01672                         ISAME( 7 ) = LDAS.EQ.LDA
01673                         ISAME( 8 ) = LSE( BS, BB, LBB )
01674                         ISAME( 9 ) = LDBS.EQ.LDB
01675                         ISAME( 10 ) = BETS.EQ.BETA
01676                         IF( NULL )THEN
01677                            ISAME( 11 ) = LSE( CS, CC, LCC )
01678                         ELSE
01679                            ISAME( 11 ) = LSERES( 'SY', UPLO, N, N, CS,
01680      $                                   CC, LDC )
01681                         END IF
01682                         ISAME( 12 ) = LDCS.EQ.LDC
01683 *
01684 *                       If data was incorrectly changed, report and
01685 *                       return.
01686 *
01687                         SAME = .TRUE.
01688                         DO 40 I = 1, NARGS
01689                            SAME = SAME.AND.ISAME( I )
01690                            IF( .NOT.ISAME( I ) )
01691      $                        WRITE( NOUT, FMT = 9998 )I
01692    40                   CONTINUE
01693                         IF( .NOT.SAME )THEN
01694                            FATAL = .TRUE.
01695                            GO TO 150
01696                         END IF
01697 *
01698                         IF( .NOT.NULL )THEN
01699 *
01700 *                          Check the result column by column.
01701 *
01702                            JJAB = 1
01703                            JC = 1
01704                            DO 70 J = 1, N
01705                               IF( UPPER )THEN
01706                                  JJ = 1
01707                                  LJ = J
01708                               ELSE
01709                                  JJ = J
01710                                  LJ = N - J + 1
01711                               END IF
01712                               IF( TRAN )THEN
01713                                  DO 50 I = 1, K
01714                                     W( I ) = AB( ( J - 1 )*2*NMAX + K +
01715      $                                       I )
01716                                     W( K + I ) = AB( ( J - 1 )*2*NMAX +
01717      $                                           I )
01718    50                            CONTINUE
01719                                  CALL SMMCH( 'T', 'N', LJ, 1, 2*K,
01720      $                                       ALPHA, AB( JJAB ), 2*NMAX,
01721      $                                       W, 2*NMAX, BETA,
01722      $                                       C( JJ, J ), NMAX, CT, G,
01723      $                                       CC( JC ), LDC, EPS, ERR,
01724      $                                       FATAL, NOUT, .TRUE. )
01725                               ELSE
01726                                  DO 60 I = 1, K
01727                                     W( I ) = AB( ( K + I - 1 )*NMAX +
01728      $                                       J )
01729                                     W( K + I ) = AB( ( I - 1 )*NMAX +
01730      $                                           J )
01731    60                            CONTINUE
01732                                  CALL SMMCH( 'N', 'N', LJ, 1, 2*K,
01733      $                                       ALPHA, AB( JJ ), NMAX, W,
01734      $                                       2*NMAX, BETA, C( JJ, J ),
01735      $                                       NMAX, CT, G, CC( JC ), LDC,
01736      $                                       EPS, ERR, FATAL, NOUT,
01737      $                                       .TRUE. )
01738                               END IF
01739                               IF( UPPER )THEN
01740                                  JC = JC + LDC
01741                               ELSE
01742                                  JC = JC + LDC + 1
01743                                  IF( TRAN )
01744      $                              JJAB = JJAB + 2*NMAX
01745                               END IF
01746                               ERRMAX = MAX( ERRMAX, ERR )
01747 *                             If got really bad answer, report and
01748 *                             return.
01749                               IF( FATAL )
01750      $                           GO TO 140
01751    70                      CONTINUE
01752                         END IF
01753 *
01754    80                CONTINUE
01755 *
01756    90             CONTINUE
01757 *
01758   100          CONTINUE
01759 *
01760   110       CONTINUE
01761 *
01762   120    CONTINUE
01763 *
01764   130 CONTINUE
01765 *
01766 *     Report result.
01767 *
01768       IF( ERRMAX.LT.THRESH )THEN
01769          WRITE( NOUT, FMT = 9999 )SNAME, NC
01770       ELSE
01771          WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
01772       END IF
01773       GO TO 160
01774 *
01775   140 CONTINUE
01776       IF( N.GT.1 )
01777      $   WRITE( NOUT, FMT = 9995 )J
01778 *
01779   150 CONTINUE
01780       WRITE( NOUT, FMT = 9996 )SNAME
01781       WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
01782      $   LDA, LDB, BETA, LDC
01783 *
01784   160 CONTINUE
01785       RETURN
01786 *
01787  9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
01788      $      'S)' )
01789  9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
01790      $      'ANGED INCORRECTLY *******' )
01791  9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
01792      $      'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
01793      $      ' - SUSPECT *******' )
01794  9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
01795  9995 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
01796  9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
01797      $      F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ')   ',
01798      $      ' .' )
01799  9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
01800      $      '******' )
01801 *
01802 *     End of SCHK5.
01803 *
01804       END
01805       SUBROUTINE SCHKE( ISNUM, SRNAMT, NOUT )
01806 *
01807 *  Tests the error exits from the Level 3 Blas.
01808 *  Requires a special version of the error-handling routine XERBLA.
01809 *  A, B and C should not need to be defined.
01810 *
01811 *  Auxiliary routine for test program for Level 3 Blas.
01812 *
01813 *  -- Written on 8-February-1989.
01814 *     Jack Dongarra, Argonne National Laboratory.
01815 *     Iain Duff, AERE Harwell.
01816 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
01817 *     Sven Hammarling, Numerical Algorithms Group Ltd.
01818 *
01819 *  3-19-92:  Initialize ALPHA and BETA  (eca)
01820 *  3-19-92:  Fix argument 12 in calls to SSYMM with INFOT = 9  (eca)
01821 *
01822 *     .. Scalar Arguments ..
01823       INTEGER            ISNUM, NOUT
01824       CHARACTER*6        SRNAMT
01825 *     .. Scalars in Common ..
01826       INTEGER            INFOT, NOUTC
01827       LOGICAL            LERR, OK
01828 *     .. Parameters ..
01829       REAL               ONE, TWO
01830       PARAMETER          ( ONE = 1.0E0, TWO = 2.0E0 )
01831 *     .. Local Scalars ..
01832       REAL               ALPHA, BETA
01833 *     .. Local Arrays ..
01834       REAL               A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
01835 *     .. External Subroutines ..
01836       EXTERNAL           CHKXER, SGEMM, SSYMM, SSYR2K, SSYRK, STRMM,
01837      $                   STRSM
01838 *     .. Common blocks ..
01839       COMMON             /INFOC/INFOT, NOUTC, OK, LERR
01840 *     .. Executable Statements ..
01841 *     OK is set to .FALSE. by the special version of XERBLA or by CHKXER
01842 *     if anything is wrong.
01843       OK = .TRUE.
01844 *     LERR is set to .TRUE. by the special version of XERBLA each time
01845 *     it is called, and is then tested and re-set by CHKXER.
01846       LERR = .FALSE.
01847 *
01848 *     Initialize ALPHA and BETA.
01849 *
01850       ALPHA = ONE
01851       BETA = TWO
01852 *
01853       GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
01854    10 INFOT = 1
01855       CALL SGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01856       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01857       INFOT = 1
01858       CALL SGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01859       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01860       INFOT = 2
01861       CALL SGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01862       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01863       INFOT = 2
01864       CALL SGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01865       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01866       INFOT = 3
01867       CALL SGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01868       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01869       INFOT = 3
01870       CALL SGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01871       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01872       INFOT = 3
01873       CALL SGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01874       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01875       INFOT = 3
01876       CALL SGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01877       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01878       INFOT = 4
01879       CALL SGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01880       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01881       INFOT = 4
01882       CALL SGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01883       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01884       INFOT = 4
01885       CALL SGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01886       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01887       INFOT = 4
01888       CALL SGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01889       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01890       INFOT = 5
01891       CALL SGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
01892       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01893       INFOT = 5
01894       CALL SGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
01895       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01896       INFOT = 5
01897       CALL SGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
01898       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01899       INFOT = 5
01900       CALL SGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
01901       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01902       INFOT = 8
01903       CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
01904       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01905       INFOT = 8
01906       CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
01907       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01908       INFOT = 8
01909       CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
01910       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01911       INFOT = 8
01912       CALL SGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
01913       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01914       INFOT = 10
01915       CALL SGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
01916       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01917       INFOT = 10
01918       CALL SGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
01919       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01920       INFOT = 10
01921       CALL SGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01922       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01923       INFOT = 10
01924       CALL SGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01925       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01926       INFOT = 13
01927       CALL SGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
01928       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01929       INFOT = 13
01930       CALL SGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
01931       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01932       INFOT = 13
01933       CALL SGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01934       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01935       INFOT = 13
01936       CALL SGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01937       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01938       GO TO 70
01939    20 INFOT = 1
01940       CALL SSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01941       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01942       INFOT = 2
01943       CALL SSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01944       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01945       INFOT = 3
01946       CALL SSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01947       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01948       INFOT = 3
01949       CALL SSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01950       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01951       INFOT = 3
01952       CALL SSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01953       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01954       INFOT = 3
01955       CALL SSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
01956       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01957       INFOT = 4
01958       CALL SSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
01959       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01960       INFOT = 4
01961       CALL SSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
01962       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01963       INFOT = 4
01964       CALL SSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
01965       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01966       INFOT = 4
01967       CALL SSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
01968       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01969       INFOT = 7
01970       CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
01971       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01972       INFOT = 7
01973       CALL SSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
01974       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01975       INFOT = 7
01976       CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
01977       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01978       INFOT = 7
01979       CALL SSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
01980       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01981       INFOT = 9
01982       CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
01983       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01984       INFOT = 9
01985       CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
01986       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01987       INFOT = 9
01988       CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
01989       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01990       INFOT = 9
01991       CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
01992       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01993       INFOT = 12
01994       CALL SSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
01995       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01996       INFOT = 12
01997       CALL SSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
01998       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
01999       INFOT = 12
02000       CALL SSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
02001       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02002       INFOT = 12
02003       CALL SSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
02004       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02005       GO TO 70
02006    30 INFOT = 1
02007       CALL STRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
02008       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02009       INFOT = 2
02010       CALL STRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
02011       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02012       INFOT = 3
02013       CALL STRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
02014       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02015       INFOT = 4
02016       CALL STRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
02017       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02018       INFOT = 5
02019       CALL STRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02020       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02021       INFOT = 5
02022       CALL STRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02023       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02024       INFOT = 5
02025       CALL STRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02026       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02027       INFOT = 5
02028       CALL STRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02029       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02030       INFOT = 5
02031       CALL STRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02032       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02033       INFOT = 5
02034       CALL STRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02035       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02036       INFOT = 5
02037       CALL STRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02038       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02039       INFOT = 5
02040       CALL STRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02041       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02042       INFOT = 6
02043       CALL STRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02044       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02045       INFOT = 6
02046       CALL STRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02047       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02048       INFOT = 6
02049       CALL STRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02050       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02051       INFOT = 6
02052       CALL STRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02053       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02054       INFOT = 6
02055       CALL STRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02056       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02057       INFOT = 6
02058       CALL STRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02059       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02060       INFOT = 6
02061       CALL STRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02062       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02063       INFOT = 6
02064       CALL STRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02065       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02066       INFOT = 9
02067       CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
02068       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02069       INFOT = 9
02070       CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
02071       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02072       INFOT = 9
02073       CALL STRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
02074       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02075       INFOT = 9
02076       CALL STRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
02077       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02078       INFOT = 9
02079       CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
02080       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02081       INFOT = 9
02082       CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
02083       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02084       INFOT = 9
02085       CALL STRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
02086       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02087       INFOT = 9
02088       CALL STRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
02089       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02090       INFOT = 11
02091       CALL STRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
02092       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02093       INFOT = 11
02094       CALL STRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
02095       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02096       INFOT = 11
02097       CALL STRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
02098       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02099       INFOT = 11
02100       CALL STRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
02101       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02102       INFOT = 11
02103       CALL STRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
02104       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02105       INFOT = 11
02106       CALL STRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
02107       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02108       INFOT = 11
02109       CALL STRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
02110       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02111       INFOT = 11
02112       CALL STRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
02113       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02114       GO TO 70
02115    40 INFOT = 1
02116       CALL STRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
02117       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02118       INFOT = 2
02119       CALL STRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
02120       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02121       INFOT = 3
02122       CALL STRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
02123       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02124       INFOT = 4
02125       CALL STRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
02126       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02127       INFOT = 5
02128       CALL STRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02129       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02130       INFOT = 5
02131       CALL STRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02132       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02133       INFOT = 5
02134       CALL STRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02135       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02136       INFOT = 5
02137       CALL STRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02138       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02139       INFOT = 5
02140       CALL STRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02141       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02142       INFOT = 5
02143       CALL STRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02144       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02145       INFOT = 5
02146       CALL STRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02147       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02148       INFOT = 5
02149       CALL STRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
02150       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02151       INFOT = 6
02152       CALL STRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02153       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02154       INFOT = 6
02155       CALL STRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02156       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02157       INFOT = 6
02158       CALL STRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02159       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02160       INFOT = 6
02161       CALL STRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02162       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02163       INFOT = 6
02164       CALL STRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02165       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02166       INFOT = 6
02167       CALL STRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02168       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02169       INFOT = 6
02170       CALL STRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02171       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02172       INFOT = 6
02173       CALL STRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
02174       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02175       INFOT = 9
02176       CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
02177       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02178       INFOT = 9
02179       CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
02180       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02181       INFOT = 9
02182       CALL STRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
02183       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02184       INFOT = 9
02185       CALL STRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
02186       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02187       INFOT = 9
02188       CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
02189       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02190       INFOT = 9
02191       CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
02192       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02193       INFOT = 9
02194       CALL STRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
02195       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02196       INFOT = 9
02197       CALL STRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
02198       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02199       INFOT = 11
02200       CALL STRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
02201       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02202       INFOT = 11
02203       CALL STRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
02204       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02205       INFOT = 11
02206       CALL STRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
02207       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02208       INFOT = 11
02209       CALL STRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
02210       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02211       INFOT = 11
02212       CALL STRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
02213       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02214       INFOT = 11
02215       CALL STRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
02216       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02217       INFOT = 11
02218       CALL STRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
02219       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02220       INFOT = 11
02221       CALL STRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
02222       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02223       GO TO 70
02224    50 INFOT = 1
02225       CALL SSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
02226       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02227       INFOT = 2
02228       CALL SSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 )
02229       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02230       INFOT = 3
02231       CALL SSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
02232       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02233       INFOT = 3
02234       CALL SSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
02235       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02236       INFOT = 3
02237       CALL SSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
02238       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02239       INFOT = 3
02240       CALL SSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
02241       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02242       INFOT = 4
02243       CALL SSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
02244       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02245       INFOT = 4
02246       CALL SSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
02247       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02248       INFOT = 4
02249       CALL SSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
02250       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02251       INFOT = 4
02252       CALL SSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
02253       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02254       INFOT = 7
02255       CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
02256       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02257       INFOT = 7
02258       CALL SSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
02259       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02260       INFOT = 7
02261       CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
02262       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02263       INFOT = 7
02264       CALL SSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
02265       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02266       INFOT = 10
02267       CALL SSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
02268       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02269       INFOT = 10
02270       CALL SSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
02271       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02272       INFOT = 10
02273       CALL SSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
02274       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02275       INFOT = 10
02276       CALL SSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
02277       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02278       GO TO 70
02279    60 INFOT = 1
02280       CALL SSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
02281       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02282       INFOT = 2
02283       CALL SSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
02284       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02285       INFOT = 3
02286       CALL SSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
02287       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02288       INFOT = 3
02289       CALL SSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
02290       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02291       INFOT = 3
02292       CALL SSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
02293       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02294       INFOT = 3
02295       CALL SSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
02296       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02297       INFOT = 4
02298       CALL SSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
02299       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02300       INFOT = 4
02301       CALL SSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
02302       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02303       INFOT = 4
02304       CALL SSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
02305       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02306       INFOT = 4
02307       CALL SSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
02308       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02309       INFOT = 7
02310       CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
02311       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02312       INFOT = 7
02313       CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
02314       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02315       INFOT = 7
02316       CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
02317       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02318       INFOT = 7
02319       CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
02320       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02321       INFOT = 9
02322       CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
02323       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02324       INFOT = 9
02325       CALL SSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
02326       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02327       INFOT = 9
02328       CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
02329       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02330       INFOT = 9
02331       CALL SSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
02332       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02333       INFOT = 12
02334       CALL SSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
02335       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02336       INFOT = 12
02337       CALL SSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
02338       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02339       INFOT = 12
02340       CALL SSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
02341       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02342       INFOT = 12
02343       CALL SSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
02344       CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02345 *
02346    70 IF( OK )THEN
02347          WRITE( NOUT, FMT = 9999 )SRNAMT
02348       ELSE
02349          WRITE( NOUT, FMT = 9998 )SRNAMT
02350       END IF
02351       RETURN
02352 *
02353  9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
02354  9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
02355      $      '**' )
02356 *
02357 *     End of SCHKE.
02358 *
02359       END
02360       SUBROUTINE SMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
02361      $                  TRANSL )
02362 *
02363 *  Generates values for an M by N matrix A.
02364 *  Stores the values in the array AA in the data structure required
02365 *  by the routine, with unwanted elements set to rogue value.
02366 *
02367 *  TYPE is 'GE', 'SY' or 'TR'.
02368 *
02369 *  Auxiliary routine for test program for Level 3 Blas.
02370 *
02371 *  -- Written on 8-February-1989.
02372 *     Jack Dongarra, Argonne National Laboratory.
02373 *     Iain Duff, AERE Harwell.
02374 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
02375 *     Sven Hammarling, Numerical Algorithms Group Ltd.
02376 *
02377 *     .. Parameters ..
02378       REAL               ZERO, ONE
02379       PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
02380       REAL               ROGUE
02381       PARAMETER          ( ROGUE = -1.0E10 )
02382 *     .. Scalar Arguments ..
02383       REAL               TRANSL
02384       INTEGER            LDA, M, N, NMAX
02385       LOGICAL            RESET
02386       CHARACTER*1        DIAG, UPLO
02387       CHARACTER*2        TYPE
02388 *     .. Array Arguments ..
02389       REAL               A( NMAX, * ), AA( * )
02390 *     .. Local Scalars ..
02391       INTEGER            I, IBEG, IEND, J
02392       LOGICAL            GEN, LOWER, SYM, TRI, UNIT, UPPER
02393 *     .. External Functions ..
02394       REAL               SBEG
02395       EXTERNAL           SBEG
02396 *     .. Executable Statements ..
02397       GEN = TYPE.EQ.'GE'
02398       SYM = TYPE.EQ.'SY'
02399       TRI = TYPE.EQ.'TR'
02400       UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
02401       LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
02402       UNIT = TRI.AND.DIAG.EQ.'U'
02403 *
02404 *     Generate data in array A.
02405 *
02406       DO 20 J = 1, N
02407          DO 10 I = 1, M
02408             IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
02409      $          THEN
02410                A( I, J ) = SBEG( RESET ) + TRANSL
02411                IF( I.NE.J )THEN
02412 *                 Set some elements to zero
02413                   IF( N.GT.3.AND.J.EQ.N/2 )
02414      $               A( I, J ) = ZERO
02415                   IF( SYM )THEN
02416                      A( J, I ) = A( I, J )
02417                   ELSE IF( TRI )THEN
02418                      A( J, I ) = ZERO
02419                   END IF
02420                END IF
02421             END IF
02422    10    CONTINUE
02423          IF( TRI )
02424      $      A( J, J ) = A( J, J ) + ONE
02425          IF( UNIT )
02426      $      A( J, J ) = ONE
02427    20 CONTINUE
02428 *
02429 *     Store elements in array AS in data structure required by routine.
02430 *
02431       IF( TYPE.EQ.'GE' )THEN
02432          DO 50 J = 1, N
02433             DO 30 I = 1, M
02434                AA( I + ( J - 1 )*LDA ) = A( I, J )
02435    30       CONTINUE
02436             DO 40 I = M + 1, LDA
02437                AA( I + ( J - 1 )*LDA ) = ROGUE
02438    40       CONTINUE
02439    50    CONTINUE
02440       ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
02441          DO 90 J = 1, N
02442             IF( UPPER )THEN
02443                IBEG = 1
02444                IF( UNIT )THEN
02445                   IEND = J - 1
02446                ELSE
02447                   IEND = J
02448                END IF
02449             ELSE
02450                IF( UNIT )THEN
02451                   IBEG = J + 1
02452                ELSE
02453                   IBEG = J
02454                END IF
02455                IEND = N
02456             END IF
02457             DO 60 I = 1, IBEG - 1
02458                AA( I + ( J - 1 )*LDA ) = ROGUE
02459    60       CONTINUE
02460             DO 70 I = IBEG, IEND
02461                AA( I + ( J - 1 )*LDA ) = A( I, J )
02462    70       CONTINUE
02463             DO 80 I = IEND + 1, LDA
02464                AA( I + ( J - 1 )*LDA ) = ROGUE
02465    80       CONTINUE
02466    90    CONTINUE
02467       END IF
02468       RETURN
02469 *
02470 *     End of SMAKE.
02471 *
02472       END
02473       SUBROUTINE SMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
02474      $                  BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
02475      $                  NOUT, MV )
02476 *
02477 *  Checks the results of the computational tests.
02478 *
02479 *  Auxiliary routine for test program for Level 3 Blas.
02480 *
02481 *  -- Written on 8-February-1989.
02482 *     Jack Dongarra, Argonne National Laboratory.
02483 *     Iain Duff, AERE Harwell.
02484 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
02485 *     Sven Hammarling, Numerical Algorithms Group Ltd.
02486 *
02487 *     .. Parameters ..
02488       REAL               ZERO, ONE
02489       PARAMETER          ( ZERO = 0.0, ONE = 1.0 )
02490 *     .. Scalar Arguments ..
02491       REAL               ALPHA, BETA, EPS, ERR
02492       INTEGER            KK, LDA, LDB, LDC, LDCC, M, N, NOUT
02493       LOGICAL            FATAL, MV
02494       CHARACTER*1        TRANSA, TRANSB
02495 *     .. Array Arguments ..
02496       REAL               A( LDA, * ), B( LDB, * ), C( LDC, * ),
02497      $                   CC( LDCC, * ), CT( * ), G( * )
02498 *     .. Local Scalars ..
02499       REAL               ERRI
02500       INTEGER            I, J, K
02501       LOGICAL            TRANA, TRANB
02502 *     .. Intrinsic Functions ..
02503       INTRINSIC          ABS, MAX, SQRT
02504 *     .. Executable Statements ..
02505       TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
02506       TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
02507 *
02508 *     Compute expected result, one column at a time, in CT using data
02509 *     in A, B and C.
02510 *     Compute gauges in G.
02511 *
02512       DO 120 J = 1, N
02513 *
02514          DO 10 I = 1, M
02515             CT( I ) = ZERO
02516             G( I ) = ZERO
02517    10    CONTINUE
02518          IF( .NOT.TRANA.AND..NOT.TRANB )THEN
02519             DO 30 K = 1, KK
02520                DO 20 I = 1, M
02521                   CT( I ) = CT( I ) + A( I, K )*B( K, J )
02522                   G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
02523    20          CONTINUE
02524    30       CONTINUE
02525          ELSE IF( TRANA.AND..NOT.TRANB )THEN
02526             DO 50 K = 1, KK
02527                DO 40 I = 1, M
02528                   CT( I ) = CT( I ) + A( K, I )*B( K, J )
02529                   G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
02530    40          CONTINUE
02531    50       CONTINUE
02532          ELSE IF( .NOT.TRANA.AND.TRANB )THEN
02533             DO 70 K = 1, KK
02534                DO 60 I = 1, M
02535                   CT( I ) = CT( I ) + A( I, K )*B( J, K )
02536                   G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
02537    60          CONTINUE
02538    70       CONTINUE
02539          ELSE IF( TRANA.AND.TRANB )THEN
02540             DO 90 K = 1, KK
02541                DO 80 I = 1, M
02542                   CT( I ) = CT( I ) + A( K, I )*B( J, K )
02543                   G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
02544    80          CONTINUE
02545    90       CONTINUE
02546          END IF
02547          DO 100 I = 1, M
02548             CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
02549             G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
02550   100    CONTINUE
02551 *
02552 *        Compute the error ratio for this result.
02553 *
02554          ERR = ZERO
02555          DO 110 I = 1, M
02556             ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
02557             IF( G( I ).NE.ZERO )
02558      $         ERRI = ERRI/G( I )
02559             ERR = MAX( ERR, ERRI )
02560             IF( ERR*SQRT( EPS ).GE.ONE )
02561      $         GO TO 130
02562   110    CONTINUE
02563 *
02564   120 CONTINUE
02565 *
02566 *     If the loop completes, all results are at least half accurate.
02567       GO TO 150
02568 *
02569 *     Report fatal error.
02570 *
02571   130 FATAL = .TRUE.
02572       WRITE( NOUT, FMT = 9999 )
02573       DO 140 I = 1, M
02574          IF( MV )THEN
02575             WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
02576          ELSE
02577             WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
02578          END IF
02579   140 CONTINUE
02580       IF( N.GT.1 )
02581      $   WRITE( NOUT, FMT = 9997 )J
02582 *
02583   150 CONTINUE
02584       RETURN
02585 *
02586  9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
02587      $      'F ACCURATE *******', /'           EXPECTED RESULT   COMPU',
02588      $      'TED RESULT' )
02589  9998 FORMAT( 1X, I7, 2G18.6 )
02590  9997 FORMAT( '      THESE ARE THE RESULTS FOR COLUMN ', I3 )
02591 *
02592 *     End of SMMCH.
02593 *
02594       END
02595       LOGICAL FUNCTION LSE( RI, RJ, LR )
02596 *
02597 *  Tests if two arrays are identical.
02598 *
02599 *  Auxiliary routine for test program for Level 3 Blas.
02600 *
02601 *  -- Written on 8-February-1989.
02602 *     Jack Dongarra, Argonne National Laboratory.
02603 *     Iain Duff, AERE Harwell.
02604 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
02605 *     Sven Hammarling, Numerical Algorithms Group Ltd.
02606 *
02607 *     .. Scalar Arguments ..
02608       INTEGER            LR
02609 *     .. Array Arguments ..
02610       REAL               RI( * ), RJ( * )
02611 *     .. Local Scalars ..
02612       INTEGER            I
02613 *     .. Executable Statements ..
02614       DO 10 I = 1, LR
02615          IF( RI( I ).NE.RJ( I ) )
02616      $      GO TO 20
02617    10 CONTINUE
02618       LSE = .TRUE.
02619       GO TO 30
02620    20 CONTINUE
02621       LSE = .FALSE.
02622    30 RETURN
02623 *
02624 *     End of LSE.
02625 *
02626       END
02627       LOGICAL FUNCTION LSERES( TYPE, UPLO, M, N, AA, AS, LDA )
02628 *
02629 *  Tests if selected elements in two arrays are equal.
02630 *
02631 *  TYPE is 'GE' or 'SY'.
02632 *
02633 *  Auxiliary routine for test program for Level 3 Blas.
02634 *
02635 *  -- Written on 8-February-1989.
02636 *     Jack Dongarra, Argonne National Laboratory.
02637 *     Iain Duff, AERE Harwell.
02638 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
02639 *     Sven Hammarling, Numerical Algorithms Group Ltd.
02640 *
02641 *     .. Scalar Arguments ..
02642       INTEGER            LDA, M, N
02643       CHARACTER*1        UPLO
02644       CHARACTER*2        TYPE
02645 *     .. Array Arguments ..
02646       REAL               AA( LDA, * ), AS( LDA, * )
02647 *     .. Local Scalars ..
02648       INTEGER            I, IBEG, IEND, J
02649       LOGICAL            UPPER
02650 *     .. Executable Statements ..
02651       UPPER = UPLO.EQ.'U'
02652       IF( TYPE.EQ.'GE' )THEN
02653          DO 20 J = 1, N
02654             DO 10 I = M + 1, LDA
02655                IF( AA( I, J ).NE.AS( I, J ) )
02656      $            GO TO 70
02657    10       CONTINUE
02658    20    CONTINUE
02659       ELSE IF( TYPE.EQ.'SY' )THEN
02660          DO 50 J = 1, N
02661             IF( UPPER )THEN
02662                IBEG = 1
02663                IEND = J
02664             ELSE
02665                IBEG = J
02666                IEND = N
02667             END IF
02668             DO 30 I = 1, IBEG - 1
02669                IF( AA( I, J ).NE.AS( I, J ) )
02670      $            GO TO 70
02671    30       CONTINUE
02672             DO 40 I = IEND + 1, LDA
02673                IF( AA( I, J ).NE.AS( I, J ) )
02674      $            GO TO 70
02675    40       CONTINUE
02676    50    CONTINUE
02677       END IF
02678 *
02679    60 CONTINUE
02680       LSERES = .TRUE.
02681       GO TO 80
02682    70 CONTINUE
02683       LSERES = .FALSE.
02684    80 RETURN
02685 *
02686 *     End of LSERES.
02687 *
02688       END
02689       REAL FUNCTION SBEG( RESET )
02690 *
02691 *  Generates random numbers uniformly distributed between -0.5 and 0.5.
02692 *
02693 *  Auxiliary routine for test program for Level 3 Blas.
02694 *
02695 *  -- Written on 8-February-1989.
02696 *     Jack Dongarra, Argonne National Laboratory.
02697 *     Iain Duff, AERE Harwell.
02698 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
02699 *     Sven Hammarling, Numerical Algorithms Group Ltd.
02700 *
02701 *     .. Scalar Arguments ..
02702       LOGICAL            RESET
02703 *     .. Local Scalars ..
02704       INTEGER            I, IC, MI
02705 *     .. Save statement ..
02706       SAVE               I, IC, MI
02707 *     .. Executable Statements ..
02708       IF( RESET )THEN
02709 *        Initialize local variables.
02710          MI = 891
02711          I = 7
02712          IC = 0
02713          RESET = .FALSE.
02714       END IF
02715 *
02716 *     The sequence of values of I is bounded between 1 and 999.
02717 *     If initial I = 1,2,3,6,7 or 9, the period will be 50.
02718 *     If initial I = 4 or 8, the period will be 25.
02719 *     If initial I = 5, the period will be 10.
02720 *     IC is used to break up the period by skipping 1 value of I in 6.
02721 *
02722       IC = IC + 1
02723    10 I = I*MI
02724       I = I - 1000*( I/1000 )
02725       IF( IC.GE.5 )THEN
02726          IC = 0
02727          GO TO 10
02728       END IF
02729       SBEG = ( I - 500 )/1001.0
02730       RETURN
02731 *
02732 *     End of SBEG.
02733 *
02734       END
02735       REAL FUNCTION SDIFF( X, Y )
02736 *
02737 *  Auxiliary routine for test program for Level 3 Blas.
02738 *
02739 *  -- Written on 8-February-1989.
02740 *     Jack Dongarra, Argonne National Laboratory.
02741 *     Iain Duff, AERE Harwell.
02742 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
02743 *     Sven Hammarling, Numerical Algorithms Group Ltd.
02744 *
02745 *     .. Scalar Arguments ..
02746       REAL               X, Y
02747 *     .. Executable Statements ..
02748       SDIFF = X - Y
02749       RETURN
02750 *
02751 *     End of SDIFF.
02752 *
02753       END
02754       SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
02755 *
02756 *  Tests whether XERBLA has detected an error when it should.
02757 *
02758 *  Auxiliary routine for test program for Level 3 Blas.
02759 *
02760 *  -- Written on 8-February-1989.
02761 *     Jack Dongarra, Argonne National Laboratory.
02762 *     Iain Duff, AERE Harwell.
02763 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
02764 *     Sven Hammarling, Numerical Algorithms Group Ltd.
02765 *
02766 *     .. Scalar Arguments ..
02767       INTEGER            INFOT, NOUT
02768       LOGICAL            LERR, OK
02769       CHARACTER*6        SRNAMT
02770 *     .. Executable Statements ..
02771       IF( .NOT.LERR )THEN
02772          WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
02773          OK = .FALSE.
02774       END IF
02775       LERR = .FALSE.
02776       RETURN
02777 *
02778  9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
02779      $      'ETECTED BY ', A6, ' *****' )
02780 *
02781 *     End of CHKXER.
02782 *
02783       END
02784       SUBROUTINE XERBLA( SRNAME, INFO )
02785 *
02786 *  This is a special version of XERBLA to be used only as part of
02787 *  the test program for testing error exits from the Level 3 BLAS
02788 *  routines.
02789 *
02790 *  XERBLA  is an error handler for the Level 3 BLAS routines.
02791 *
02792 *  It is called by the Level 3 BLAS routines if an input parameter is
02793 *  invalid.
02794 *
02795 *  Auxiliary routine for test program for Level 3 Blas.
02796 *
02797 *  -- Written on 8-February-1989.
02798 *     Jack Dongarra, Argonne National Laboratory.
02799 *     Iain Duff, AERE Harwell.
02800 *     Jeremy Du Croz, Numerical Algorithms Group Ltd.
02801 *     Sven Hammarling, Numerical Algorithms Group Ltd.
02802 *
02803 *     .. Scalar Arguments ..
02804       INTEGER            INFO
02805       CHARACTER*6        SRNAME
02806 *     .. Scalars in Common ..
02807       INTEGER            INFOT, NOUT
02808       LOGICAL            LERR, OK
02809       CHARACTER*6        SRNAMT
02810 *     .. Common blocks ..
02811       COMMON             /INFOC/INFOT, NOUT, OK, LERR
02812       COMMON             /SRNAMC/SRNAMT
02813 *     .. Executable Statements ..
02814       LERR = .TRUE.
02815       IF( INFO.NE.INFOT )THEN
02816          IF( INFOT.NE.0 )THEN
02817             WRITE( NOUT, FMT = 9999 )INFO, INFOT
02818          ELSE
02819             WRITE( NOUT, FMT = 9997 )INFO
02820          END IF
02821          OK = .FALSE.
02822       END IF
02823       IF( SRNAME.NE.SRNAMT )THEN
02824          WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
02825          OK = .FALSE.
02826       END IF
02827       RETURN
02828 *
02829  9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
02830      $      ' OF ', I2, ' *******' )
02831  9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
02832      $      'AD OF ', A6, ' *******' )
02833  9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
02834      $      ' *******' )
02835 *
02836 *     End of XERBLA
02837 *
02838       END
02839