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