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