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