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