LAPACK: BLAS/TESTING/zblat2.f Source File

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