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