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