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