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