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