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