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