1*1858f998SYi Kong PROGRAM SCBLAT1 2*1858f998SYi Kong* Test program for the REAL Level 1 CBLAS. 3*1858f998SYi Kong* Based upon the original CBLAS test routine together with: 4*1858f998SYi Kong* F06EAF Example Program Text 5*1858f998SYi Kong* .. Parameters .. 6*1858f998SYi Kong INTEGER NOUT 7*1858f998SYi Kong PARAMETER (NOUT=6) 8*1858f998SYi Kong* .. Scalars in Common .. 9*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 10*1858f998SYi Kong LOGICAL PASS 11*1858f998SYi Kong* .. Local Scalars .. 12*1858f998SYi Kong REAL SFAC 13*1858f998SYi Kong INTEGER IC 14*1858f998SYi Kong* .. External Subroutines .. 15*1858f998SYi Kong EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER 16*1858f998SYi Kong* .. Common blocks .. 17*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 18*1858f998SYi Kong* .. Data statements .. 19*1858f998SYi Kong DATA SFAC/9.765625E-4/ 20*1858f998SYi Kong* .. Executable Statements .. 21*1858f998SYi Kong WRITE (NOUT,99999) 22*1858f998SYi Kong DO 20 IC = 1, 10 23*1858f998SYi Kong ICASE = IC 24*1858f998SYi Kong CALL HEADER 25*1858f998SYi Kong* 26*1858f998SYi Kong* .. Initialize PASS, INCX, INCY, and MODE for a new case. .. 27*1858f998SYi Kong* .. the value 9999 for INCX, INCY or MODE will appear in the .. 28*1858f998SYi Kong* .. detailed output, if any, for cases that do not involve .. 29*1858f998SYi Kong* .. these parameters .. 30*1858f998SYi Kong* 31*1858f998SYi Kong PASS = .TRUE. 32*1858f998SYi Kong INCX = 9999 33*1858f998SYi Kong INCY = 9999 34*1858f998SYi Kong MODE = 9999 35*1858f998SYi Kong IF (ICASE.EQ.3) THEN 36*1858f998SYi Kong CALL CHECK0(SFAC) 37*1858f998SYi Kong ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR. 38*1858f998SYi Kong + ICASE.EQ.10) THEN 39*1858f998SYi Kong CALL CHECK1(SFAC) 40*1858f998SYi Kong ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. 41*1858f998SYi Kong + ICASE.EQ.6) THEN 42*1858f998SYi Kong CALL CHECK2(SFAC) 43*1858f998SYi Kong ELSE IF (ICASE.EQ.4) THEN 44*1858f998SYi Kong CALL CHECK3(SFAC) 45*1858f998SYi Kong END IF 46*1858f998SYi Kong* -- Print 47*1858f998SYi Kong IF (PASS) WRITE (NOUT,99998) 48*1858f998SYi Kong 20 CONTINUE 49*1858f998SYi Kong STOP 50*1858f998SYi Kong* 51*1858f998SYi Kong99999 FORMAT (' Real CBLAS Test Program Results',/1X) 52*1858f998SYi Kong99998 FORMAT (' ----- PASS -----') 53*1858f998SYi Kong END 54*1858f998SYi Kong SUBROUTINE HEADER 55*1858f998SYi Kong* .. Parameters .. 56*1858f998SYi Kong INTEGER NOUT 57*1858f998SYi Kong PARAMETER (NOUT=6) 58*1858f998SYi Kong* .. Scalars in Common .. 59*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 60*1858f998SYi Kong LOGICAL PASS 61*1858f998SYi Kong* .. Local Arrays .. 62*1858f998SYi Kong CHARACTER*15 L(10) 63*1858f998SYi Kong* .. Common blocks .. 64*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 65*1858f998SYi Kong* .. Data statements .. 66*1858f998SYi Kong DATA L(1)/'CBLAS_SDOT '/ 67*1858f998SYi Kong DATA L(2)/'CBLAS_SAXPY '/ 68*1858f998SYi Kong DATA L(3)/'CBLAS_SROTG '/ 69*1858f998SYi Kong DATA L(4)/'CBLAS_SROT '/ 70*1858f998SYi Kong DATA L(5)/'CBLAS_SCOPY '/ 71*1858f998SYi Kong DATA L(6)/'CBLAS_SSWAP '/ 72*1858f998SYi Kong DATA L(7)/'CBLAS_SNRM2 '/ 73*1858f998SYi Kong DATA L(8)/'CBLAS_SASUM '/ 74*1858f998SYi Kong DATA L(9)/'CBLAS_SSCAL '/ 75*1858f998SYi Kong DATA L(10)/'CBLAS_ISAMAX'/ 76*1858f998SYi Kong* .. Executable Statements .. 77*1858f998SYi Kong WRITE (NOUT,99999) ICASE, L(ICASE) 78*1858f998SYi Kong RETURN 79*1858f998SYi Kong* 80*1858f998SYi Kong99999 FORMAT (/' Test of subprogram number',I3,9X,A15) 81*1858f998SYi Kong END 82*1858f998SYi Kong SUBROUTINE CHECK0(SFAC) 83*1858f998SYi Kong* .. Parameters .. 84*1858f998SYi Kong INTEGER NOUT 85*1858f998SYi Kong PARAMETER (NOUT=6) 86*1858f998SYi Kong* .. Scalar Arguments .. 87*1858f998SYi Kong REAL SFAC 88*1858f998SYi Kong* .. Scalars in Common .. 89*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 90*1858f998SYi Kong LOGICAL PASS 91*1858f998SYi Kong* .. Local Scalars .. 92*1858f998SYi Kong REAL SA, SB, SC, SS 93*1858f998SYi Kong INTEGER K 94*1858f998SYi Kong* .. Local Arrays .. 95*1858f998SYi Kong REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8), 96*1858f998SYi Kong + DS1(8) 97*1858f998SYi Kong* .. External Subroutines .. 98*1858f998SYi Kong EXTERNAL SROTGTEST, STEST1 99*1858f998SYi Kong* .. Common blocks .. 100*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 101*1858f998SYi Kong* .. Data statements .. 102*1858f998SYi Kong DATA DA1/0.3E0, 0.4E0, -0.3E0, -0.4E0, -0.3E0, 0.0E0, 103*1858f998SYi Kong + 0.0E0, 1.0E0/ 104*1858f998SYi Kong DATA DB1/0.4E0, 0.3E0, 0.4E0, 0.3E0, -0.4E0, 0.0E0, 105*1858f998SYi Kong + 1.0E0, 0.0E0/ 106*1858f998SYi Kong DATA DC1/0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.6E0, 1.0E0, 107*1858f998SYi Kong + 0.0E0, 1.0E0/ 108*1858f998SYi Kong DATA DS1/0.8E0, 0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.0E0, 109*1858f998SYi Kong + 1.0E0, 0.0E0/ 110*1858f998SYi Kong DATA DATRUE/0.5E0, 0.5E0, 0.5E0, -0.5E0, -0.5E0, 111*1858f998SYi Kong + 0.0E0, 1.0E0, 1.0E0/ 112*1858f998SYi Kong DATA DBTRUE/0.0E0, 0.6E0, 0.0E0, -0.6E0, 0.0E0, 113*1858f998SYi Kong + 0.0E0, 1.0E0, 0.0E0/ 114*1858f998SYi Kong* .. Executable Statements .. 115*1858f998SYi Kong* 116*1858f998SYi Kong* Compute true values which cannot be prestored 117*1858f998SYi Kong* in decimal notation 118*1858f998SYi Kong* 119*1858f998SYi Kong DBTRUE(1) = 1.0E0/0.6E0 120*1858f998SYi Kong DBTRUE(3) = -1.0E0/0.6E0 121*1858f998SYi Kong DBTRUE(5) = 1.0E0/0.6E0 122*1858f998SYi Kong* 123*1858f998SYi Kong DO 20 K = 1, 8 124*1858f998SYi Kong* .. Set N=K for identification in output if any .. 125*1858f998SYi Kong N = K 126*1858f998SYi Kong IF (ICASE.EQ.3) THEN 127*1858f998SYi Kong* .. SROTGTEST .. 128*1858f998SYi Kong IF (K.GT.8) GO TO 40 129*1858f998SYi Kong SA = DA1(K) 130*1858f998SYi Kong SB = DB1(K) 131*1858f998SYi Kong CALL SROTGTEST(SA,SB,SC,SS) 132*1858f998SYi Kong CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC) 133*1858f998SYi Kong CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC) 134*1858f998SYi Kong CALL STEST1(SC,DC1(K),DC1(K),SFAC) 135*1858f998SYi Kong CALL STEST1(SS,DS1(K),DS1(K),SFAC) 136*1858f998SYi Kong ELSE 137*1858f998SYi Kong WRITE (NOUT,*) ' Shouldn''t be here in CHECK0' 138*1858f998SYi Kong STOP 139*1858f998SYi Kong END IF 140*1858f998SYi Kong 20 CONTINUE 141*1858f998SYi Kong 40 RETURN 142*1858f998SYi Kong END 143*1858f998SYi Kong SUBROUTINE CHECK1(SFAC) 144*1858f998SYi Kong* .. Parameters .. 145*1858f998SYi Kong INTEGER NOUT 146*1858f998SYi Kong PARAMETER (NOUT=6) 147*1858f998SYi Kong* .. Scalar Arguments .. 148*1858f998SYi Kong REAL SFAC 149*1858f998SYi Kong* .. Scalars in Common .. 150*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 151*1858f998SYi Kong LOGICAL PASS 152*1858f998SYi Kong* .. Local Scalars .. 153*1858f998SYi Kong INTEGER I, LEN, NP1 154*1858f998SYi Kong* .. Local Arrays .. 155*1858f998SYi Kong REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2), 156*1858f998SYi Kong + SA(10), STEMP(1), STRUE(8), SX(8) 157*1858f998SYi Kong INTEGER ITRUE2(5) 158*1858f998SYi Kong* .. External Functions .. 159*1858f998SYi Kong REAL SASUMTEST, SNRM2TEST 160*1858f998SYi Kong INTEGER ISAMAXTEST 161*1858f998SYi Kong EXTERNAL SASUMTEST, SNRM2TEST, ISAMAXTEST 162*1858f998SYi Kong* .. External Subroutines .. 163*1858f998SYi Kong EXTERNAL ITEST1, SSCALTEST, STEST, STEST1 164*1858f998SYi Kong* .. Intrinsic Functions .. 165*1858f998SYi Kong INTRINSIC MAX 166*1858f998SYi Kong* .. Common blocks .. 167*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 168*1858f998SYi Kong* .. Data statements .. 169*1858f998SYi Kong DATA SA/0.3E0, -1.0E0, 0.0E0, 1.0E0, 0.3E0, 0.3E0, 170*1858f998SYi Kong + 0.3E0, 0.3E0, 0.3E0, 0.3E0/ 171*1858f998SYi Kong DATA DV/0.1E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 172*1858f998SYi Kong + 2.0E0, 2.0E0, 0.3E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 173*1858f998SYi Kong + 3.0E0, 3.0E0, 3.0E0, 0.3E0, -0.4E0, 4.0E0, 174*1858f998SYi Kong + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 0.2E0, 175*1858f998SYi Kong + -0.6E0, 0.3E0, 5.0E0, 5.0E0, 5.0E0, 5.0E0, 176*1858f998SYi Kong + 5.0E0, 0.1E0, -0.3E0, 0.5E0, -0.1E0, 6.0E0, 177*1858f998SYi Kong + 6.0E0, 6.0E0, 6.0E0, 0.1E0, 8.0E0, 8.0E0, 8.0E0, 178*1858f998SYi Kong + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 0.3E0, 9.0E0, 9.0E0, 179*1858f998SYi Kong + 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 0.3E0, 2.0E0, 180*1858f998SYi Kong + -0.4E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 181*1858f998SYi Kong + 0.2E0, 3.0E0, -0.6E0, 5.0E0, 0.3E0, 2.0E0, 182*1858f998SYi Kong + 2.0E0, 2.0E0, 0.1E0, 4.0E0, -0.3E0, 6.0E0, 183*1858f998SYi Kong + -0.5E0, 7.0E0, -0.1E0, 3.0E0/ 184*1858f998SYi Kong DATA DTRUE1/0.0E0, 0.3E0, 0.5E0, 0.7E0, 0.6E0/ 185*1858f998SYi Kong DATA DTRUE3/0.0E0, 0.3E0, 0.7E0, 1.1E0, 1.0E0/ 186*1858f998SYi Kong DATA DTRUE5/0.10E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 187*1858f998SYi Kong + 2.0E0, 2.0E0, 2.0E0, -0.3E0, 3.0E0, 3.0E0, 188*1858f998SYi Kong + 3.0E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 0.0E0, 0.0E0, 189*1858f998SYi Kong + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 190*1858f998SYi Kong + 0.20E0, -0.60E0, 0.30E0, 5.0E0, 5.0E0, 5.0E0, 191*1858f998SYi Kong + 5.0E0, 5.0E0, 0.03E0, -0.09E0, 0.15E0, -0.03E0, 192*1858f998SYi Kong + 6.0E0, 6.0E0, 6.0E0, 6.0E0, 0.10E0, 8.0E0, 193*1858f998SYi Kong + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 194*1858f998SYi Kong + 0.09E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 195*1858f998SYi Kong + 9.0E0, 9.0E0, 0.09E0, 2.0E0, -0.12E0, 2.0E0, 196*1858f998SYi Kong + 2.0E0, 2.0E0, 2.0E0, 2.0E0, 0.06E0, 3.0E0, 197*1858f998SYi Kong + -0.18E0, 5.0E0, 0.09E0, 2.0E0, 2.0E0, 2.0E0, 198*1858f998SYi Kong + 0.03E0, 4.0E0, -0.09E0, 6.0E0, -0.15E0, 7.0E0, 199*1858f998SYi Kong + -0.03E0, 3.0E0/ 200*1858f998SYi Kong DATA ITRUE2/0, 1, 2, 2, 3/ 201*1858f998SYi Kong* .. Executable Statements .. 202*1858f998SYi Kong DO 80 INCX = 1, 2 203*1858f998SYi Kong DO 60 NP1 = 1, 5 204*1858f998SYi Kong N = NP1 - 1 205*1858f998SYi Kong LEN = 2*MAX(N,1) 206*1858f998SYi Kong* .. Set vector arguments .. 207*1858f998SYi Kong DO 20 I = 1, LEN 208*1858f998SYi Kong SX(I) = DV(I,NP1,INCX) 209*1858f998SYi Kong 20 CONTINUE 210*1858f998SYi Kong* 211*1858f998SYi Kong IF (ICASE.EQ.7) THEN 212*1858f998SYi Kong* .. SNRM2TEST .. 213*1858f998SYi Kong STEMP(1) = DTRUE1(NP1) 214*1858f998SYi Kong CALL STEST1(SNRM2TEST(N,SX,INCX),STEMP,STEMP,SFAC) 215*1858f998SYi Kong ELSE IF (ICASE.EQ.8) THEN 216*1858f998SYi Kong* .. SASUMTEST .. 217*1858f998SYi Kong STEMP(1) = DTRUE3(NP1) 218*1858f998SYi Kong CALL STEST1(SASUMTEST(N,SX,INCX),STEMP,STEMP,SFAC) 219*1858f998SYi Kong ELSE IF (ICASE.EQ.9) THEN 220*1858f998SYi Kong* .. SSCALTEST .. 221*1858f998SYi Kong CALL SSCALTEST(N,SA((INCX-1)*5+NP1),SX,INCX) 222*1858f998SYi Kong DO 40 I = 1, LEN 223*1858f998SYi Kong STRUE(I) = DTRUE5(I,NP1,INCX) 224*1858f998SYi Kong 40 CONTINUE 225*1858f998SYi Kong CALL STEST(LEN,SX,STRUE,STRUE,SFAC) 226*1858f998SYi Kong ELSE IF (ICASE.EQ.10) THEN 227*1858f998SYi Kong* .. ISAMAXTEST .. 228*1858f998SYi Kong CALL ITEST1(ISAMAXTEST(N,SX,INCX),ITRUE2(NP1)) 229*1858f998SYi Kong ELSE 230*1858f998SYi Kong WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' 231*1858f998SYi Kong STOP 232*1858f998SYi Kong END IF 233*1858f998SYi Kong 60 CONTINUE 234*1858f998SYi Kong 80 CONTINUE 235*1858f998SYi Kong RETURN 236*1858f998SYi Kong END 237*1858f998SYi Kong SUBROUTINE CHECK2(SFAC) 238*1858f998SYi Kong* .. Parameters .. 239*1858f998SYi Kong INTEGER NOUT 240*1858f998SYi Kong PARAMETER (NOUT=6) 241*1858f998SYi Kong* .. Scalar Arguments .. 242*1858f998SYi Kong REAL SFAC 243*1858f998SYi Kong* .. Scalars in Common .. 244*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 245*1858f998SYi Kong LOGICAL PASS 246*1858f998SYi Kong* .. Local Scalars .. 247*1858f998SYi Kong REAL SA 248*1858f998SYi Kong INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY 249*1858f998SYi Kong* .. Local Arrays .. 250*1858f998SYi Kong REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), 251*1858f998SYi Kong + DT8(7,4,4), DX1(7), 252*1858f998SYi Kong + DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7), 253*1858f998SYi Kong + SX(7), SY(7) 254*1858f998SYi Kong INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) 255*1858f998SYi Kong* .. External Functions .. 256*1858f998SYi Kong REAL SDOTTEST 257*1858f998SYi Kong EXTERNAL SDOTTEST 258*1858f998SYi Kong* .. External Subroutines .. 259*1858f998SYi Kong EXTERNAL SAXPYTEST, SCOPYTEST, SSWAPTEST, STEST, STEST1 260*1858f998SYi Kong* .. Intrinsic Functions .. 261*1858f998SYi Kong INTRINSIC ABS, MIN 262*1858f998SYi Kong* .. Common blocks .. 263*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 264*1858f998SYi Kong* .. Data statements .. 265*1858f998SYi Kong DATA SA/0.3E0/ 266*1858f998SYi Kong DATA INCXS/1, 2, -2, -1/ 267*1858f998SYi Kong DATA INCYS/1, -2, 1, -2/ 268*1858f998SYi Kong DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ 269*1858f998SYi Kong DATA NS/0, 1, 2, 4/ 270*1858f998SYi Kong DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, 271*1858f998SYi Kong + -0.4E0/ 272*1858f998SYi Kong DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, 273*1858f998SYi Kong + 0.8E0/ 274*1858f998SYi Kong DATA DT7/0.0E0, 0.30E0, 0.21E0, 0.62E0, 0.0E0, 275*1858f998SYi Kong + 0.30E0, -0.07E0, 0.85E0, 0.0E0, 0.30E0, -0.79E0, 276*1858f998SYi Kong + -0.74E0, 0.0E0, 0.30E0, 0.33E0, 1.27E0/ 277*1858f998SYi Kong DATA DT8/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 278*1858f998SYi Kong + 0.0E0, 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 279*1858f998SYi Kong + 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.0E0, 0.0E0, 280*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.15E0, 281*1858f998SYi Kong + 0.94E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 282*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.68E0, 283*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 284*1858f998SYi Kong + 0.35E0, -0.9E0, 0.48E0, 0.0E0, 0.0E0, 0.0E0, 285*1858f998SYi Kong + 0.0E0, 0.38E0, -0.9E0, 0.57E0, 0.7E0, -0.75E0, 286*1858f998SYi Kong + 0.2E0, 0.98E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 287*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.68E0, 0.0E0, 0.0E0, 288*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.35E0, -0.72E0, 289*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.38E0, 290*1858f998SYi Kong + -0.63E0, 0.15E0, 0.88E0, 0.0E0, 0.0E0, 0.0E0, 291*1858f998SYi Kong + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 292*1858f998SYi Kong + 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 293*1858f998SYi Kong + 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.0E0, 0.0E0, 294*1858f998SYi Kong + 0.0E0, 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.7E0, 295*1858f998SYi Kong + -0.75E0, 0.2E0, 1.04E0/ 296*1858f998SYi Kong DATA DT10X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 297*1858f998SYi Kong + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 298*1858f998SYi Kong + 0.0E0, 0.5E0, -0.9E0, 0.0E0, 0.0E0, 0.0E0, 299*1858f998SYi Kong + 0.0E0, 0.0E0, 0.5E0, -0.9E0, 0.3E0, 0.7E0, 300*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 301*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 302*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.3E0, 0.1E0, 0.5E0, 0.0E0, 303*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.8E0, 0.1E0, -0.6E0, 304*1858f998SYi Kong + 0.8E0, 0.3E0, -0.3E0, 0.5E0, 0.6E0, 0.0E0, 305*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 306*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.9E0, 307*1858f998SYi Kong + 0.1E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, 308*1858f998SYi Kong + 0.1E0, 0.3E0, 0.8E0, -0.9E0, -0.3E0, 0.5E0, 309*1858f998SYi Kong + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 310*1858f998SYi Kong + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 311*1858f998SYi Kong + 0.5E0, 0.3E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 312*1858f998SYi Kong + 0.5E0, 0.3E0, -0.6E0, 0.8E0, 0.0E0, 0.0E0, 313*1858f998SYi Kong + 0.0E0/ 314*1858f998SYi Kong DATA DT10Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 315*1858f998SYi Kong + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 316*1858f998SYi Kong + 0.0E0, 0.6E0, 0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 317*1858f998SYi Kong + 0.0E0, 0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.0E0, 318*1858f998SYi Kong + 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 319*1858f998SYi Kong + 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 320*1858f998SYi Kong + 0.0E0, 0.0E0, -0.5E0, -0.9E0, 0.6E0, 0.0E0, 321*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, -0.4E0, -0.9E0, 0.9E0, 322*1858f998SYi Kong + 0.7E0, -0.5E0, 0.2E0, 0.6E0, 0.5E0, 0.0E0, 323*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 324*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.5E0, 325*1858f998SYi Kong + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 326*1858f998SYi Kong + -0.4E0, 0.9E0, -0.5E0, 0.6E0, 0.0E0, 0.0E0, 327*1858f998SYi Kong + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 328*1858f998SYi Kong + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 329*1858f998SYi Kong + 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.0E0, 0.0E0, 330*1858f998SYi Kong + 0.0E0, 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.7E0, 331*1858f998SYi Kong + -0.5E0, 0.2E0, 0.8E0/ 332*1858f998SYi Kong DATA SSIZE1/0.0E0, 0.3E0, 1.6E0, 3.2E0/ 333*1858f998SYi Kong DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 334*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 335*1858f998SYi Kong + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 336*1858f998SYi Kong + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 337*1858f998SYi Kong + 1.17E0, 1.17E0, 1.17E0/ 338*1858f998SYi Kong* .. Executable Statements .. 339*1858f998SYi Kong* 340*1858f998SYi Kong DO 120 KI = 1, 4 341*1858f998SYi Kong INCX = INCXS(KI) 342*1858f998SYi Kong INCY = INCYS(KI) 343*1858f998SYi Kong MX = ABS(INCX) 344*1858f998SYi Kong MY = ABS(INCY) 345*1858f998SYi Kong* 346*1858f998SYi Kong DO 100 KN = 1, 4 347*1858f998SYi Kong N = NS(KN) 348*1858f998SYi Kong KSIZE = MIN(2,KN) 349*1858f998SYi Kong LENX = LENS(KN,MX) 350*1858f998SYi Kong LENY = LENS(KN,MY) 351*1858f998SYi Kong* .. Initialize all argument arrays .. 352*1858f998SYi Kong DO 20 I = 1, 7 353*1858f998SYi Kong SX(I) = DX1(I) 354*1858f998SYi Kong SY(I) = DY1(I) 355*1858f998SYi Kong 20 CONTINUE 356*1858f998SYi Kong* 357*1858f998SYi Kong IF (ICASE.EQ.1) THEN 358*1858f998SYi Kong* .. SDOTTEST .. 359*1858f998SYi Kong CALL STEST1(SDOTTEST(N,SX,INCX,SY,INCY),DT7(KN,KI), 360*1858f998SYi Kong + SSIZE1(KN),SFAC) 361*1858f998SYi Kong ELSE IF (ICASE.EQ.2) THEN 362*1858f998SYi Kong* .. SAXPYTEST .. 363*1858f998SYi Kong CALL SAXPYTEST(N,SA,SX,INCX,SY,INCY) 364*1858f998SYi Kong DO 40 J = 1, LENY 365*1858f998SYi Kong STY(J) = DT8(J,KN,KI) 366*1858f998SYi Kong 40 CONTINUE 367*1858f998SYi Kong CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) 368*1858f998SYi Kong ELSE IF (ICASE.EQ.5) THEN 369*1858f998SYi Kong* .. SCOPYTEST .. 370*1858f998SYi Kong DO 60 I = 1, 7 371*1858f998SYi Kong STY(I) = DT10Y(I,KN,KI) 372*1858f998SYi Kong 60 CONTINUE 373*1858f998SYi Kong CALL SCOPYTEST(N,SX,INCX,SY,INCY) 374*1858f998SYi Kong CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) 375*1858f998SYi Kong ELSE IF (ICASE.EQ.6) THEN 376*1858f998SYi Kong* .. SSWAPTEST .. 377*1858f998SYi Kong CALL SSWAPTEST(N,SX,INCX,SY,INCY) 378*1858f998SYi Kong DO 80 I = 1, 7 379*1858f998SYi Kong STX(I) = DT10X(I,KN,KI) 380*1858f998SYi Kong STY(I) = DT10Y(I,KN,KI) 381*1858f998SYi Kong 80 CONTINUE 382*1858f998SYi Kong CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0E0) 383*1858f998SYi Kong CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) 384*1858f998SYi Kong ELSE 385*1858f998SYi Kong WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' 386*1858f998SYi Kong STOP 387*1858f998SYi Kong END IF 388*1858f998SYi Kong 100 CONTINUE 389*1858f998SYi Kong 120 CONTINUE 390*1858f998SYi Kong RETURN 391*1858f998SYi Kong END 392*1858f998SYi Kong SUBROUTINE CHECK3(SFAC) 393*1858f998SYi Kong* .. Parameters .. 394*1858f998SYi Kong INTEGER NOUT 395*1858f998SYi Kong PARAMETER (NOUT=6) 396*1858f998SYi Kong* .. Scalar Arguments .. 397*1858f998SYi Kong REAL SFAC 398*1858f998SYi Kong* .. Scalars in Common .. 399*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 400*1858f998SYi Kong LOGICAL PASS 401*1858f998SYi Kong* .. Local Scalars .. 402*1858f998SYi Kong REAL SC, SS 403*1858f998SYi Kong INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY 404*1858f998SYi Kong* .. Local Arrays .. 405*1858f998SYi Kong REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4), 406*1858f998SYi Kong + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5), 407*1858f998SYi Kong + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5), 408*1858f998SYi Kong + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7), 409*1858f998SYi Kong + SY(7) 410*1858f998SYi Kong INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11), 411*1858f998SYi Kong + MWPINY(11), MWPN(11), NS(4) 412*1858f998SYi Kong* .. External Subroutines .. 413*1858f998SYi Kong EXTERNAL SROTTEST, STEST 414*1858f998SYi Kong* .. Intrinsic Functions .. 415*1858f998SYi Kong INTRINSIC ABS, MIN 416*1858f998SYi Kong* .. Common blocks .. 417*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 418*1858f998SYi Kong* .. Data statements .. 419*1858f998SYi Kong DATA INCXS/1, 2, -2, -1/ 420*1858f998SYi Kong DATA INCYS/1, -2, 1, -2/ 421*1858f998SYi Kong DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ 422*1858f998SYi Kong DATA NS/0, 1, 2, 4/ 423*1858f998SYi Kong DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, 424*1858f998SYi Kong + -0.4E0/ 425*1858f998SYi Kong DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, 426*1858f998SYi Kong + 0.8E0/ 427*1858f998SYi Kong DATA SC, SS/0.8E0, 0.6E0/ 428*1858f998SYi Kong DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 429*1858f998SYi Kong + 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 430*1858f998SYi Kong + 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0, 431*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0, 432*1858f998SYi Kong + 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 433*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0, 434*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 435*1858f998SYi Kong + 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0, 436*1858f998SYi Kong + 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0, 437*1858f998SYi Kong + -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 438*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0, 439*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0, 440*1858f998SYi Kong + -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0, 441*1858f998SYi Kong + 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0, 442*1858f998SYi Kong + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 443*1858f998SYi Kong + 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 444*1858f998SYi Kong + 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0, 445*1858f998SYi Kong + 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0, 446*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0/ 447*1858f998SYi Kong DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 448*1858f998SYi Kong + 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 449*1858f998SYi Kong + 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0, 450*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0, 451*1858f998SYi Kong + 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 452*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0, 453*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, 454*1858f998SYi Kong + -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 455*1858f998SYi Kong + 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0, 456*1858f998SYi Kong + 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 457*1858f998SYi Kong + 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 458*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0, 459*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0, 460*1858f998SYi Kong + 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 461*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 462*1858f998SYi Kong + 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 463*1858f998SYi Kong + 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0, 464*1858f998SYi Kong + 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0, 465*1858f998SYi Kong + -0.18E0, 0.2E0, 0.16E0/ 466*1858f998SYi Kong DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 467*1858f998SYi Kong + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 468*1858f998SYi Kong + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 469*1858f998SYi Kong + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 470*1858f998SYi Kong + 1.17E0, 1.17E0, 1.17E0/ 471*1858f998SYi Kong* .. Executable Statements .. 472*1858f998SYi Kong* 473*1858f998SYi Kong DO 60 KI = 1, 4 474*1858f998SYi Kong INCX = INCXS(KI) 475*1858f998SYi Kong INCY = INCYS(KI) 476*1858f998SYi Kong MX = ABS(INCX) 477*1858f998SYi Kong MY = ABS(INCY) 478*1858f998SYi Kong* 479*1858f998SYi Kong DO 40 KN = 1, 4 480*1858f998SYi Kong N = NS(KN) 481*1858f998SYi Kong KSIZE = MIN(2,KN) 482*1858f998SYi Kong LENX = LENS(KN,MX) 483*1858f998SYi Kong LENY = LENS(KN,MY) 484*1858f998SYi Kong* 485*1858f998SYi Kong IF (ICASE.EQ.4) THEN 486*1858f998SYi Kong* .. SROTTEST .. 487*1858f998SYi Kong DO 20 I = 1, 7 488*1858f998SYi Kong SX(I) = DX1(I) 489*1858f998SYi Kong SY(I) = DY1(I) 490*1858f998SYi Kong STX(I) = DT9X(I,KN,KI) 491*1858f998SYi Kong STY(I) = DT9Y(I,KN,KI) 492*1858f998SYi Kong 20 CONTINUE 493*1858f998SYi Kong CALL SROTTEST(N,SX,INCX,SY,INCY,SC,SS) 494*1858f998SYi Kong CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC) 495*1858f998SYi Kong CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) 496*1858f998SYi Kong ELSE 497*1858f998SYi Kong WRITE (NOUT,*) ' Shouldn''t be here in CHECK3' 498*1858f998SYi Kong STOP 499*1858f998SYi Kong END IF 500*1858f998SYi Kong 40 CONTINUE 501*1858f998SYi Kong 60 CONTINUE 502*1858f998SYi Kong* 503*1858f998SYi Kong MWPC(1) = 1 504*1858f998SYi Kong DO 80 I = 2, 11 505*1858f998SYi Kong MWPC(I) = 0 506*1858f998SYi Kong 80 CONTINUE 507*1858f998SYi Kong MWPS(1) = 0 508*1858f998SYi Kong DO 100 I = 2, 6 509*1858f998SYi Kong MWPS(I) = 1 510*1858f998SYi Kong 100 CONTINUE 511*1858f998SYi Kong DO 120 I = 7, 11 512*1858f998SYi Kong MWPS(I) = -1 513*1858f998SYi Kong 120 CONTINUE 514*1858f998SYi Kong MWPINX(1) = 1 515*1858f998SYi Kong MWPINX(2) = 1 516*1858f998SYi Kong MWPINX(3) = 1 517*1858f998SYi Kong MWPINX(4) = -1 518*1858f998SYi Kong MWPINX(5) = 1 519*1858f998SYi Kong MWPINX(6) = -1 520*1858f998SYi Kong MWPINX(7) = 1 521*1858f998SYi Kong MWPINX(8) = 1 522*1858f998SYi Kong MWPINX(9) = -1 523*1858f998SYi Kong MWPINX(10) = 1 524*1858f998SYi Kong MWPINX(11) = -1 525*1858f998SYi Kong MWPINY(1) = 1 526*1858f998SYi Kong MWPINY(2) = 1 527*1858f998SYi Kong MWPINY(3) = -1 528*1858f998SYi Kong MWPINY(4) = -1 529*1858f998SYi Kong MWPINY(5) = 2 530*1858f998SYi Kong MWPINY(6) = 1 531*1858f998SYi Kong MWPINY(7) = 1 532*1858f998SYi Kong MWPINY(8) = -1 533*1858f998SYi Kong MWPINY(9) = -1 534*1858f998SYi Kong MWPINY(10) = 2 535*1858f998SYi Kong MWPINY(11) = 1 536*1858f998SYi Kong DO 140 I = 1, 11 537*1858f998SYi Kong MWPN(I) = 5 538*1858f998SYi Kong 140 CONTINUE 539*1858f998SYi Kong MWPN(5) = 3 540*1858f998SYi Kong MWPN(10) = 3 541*1858f998SYi Kong DO 160 I = 1, 5 542*1858f998SYi Kong MWPX(I) = I 543*1858f998SYi Kong MWPY(I) = I 544*1858f998SYi Kong MWPTX(1,I) = I 545*1858f998SYi Kong MWPTY(1,I) = I 546*1858f998SYi Kong MWPTX(2,I) = I 547*1858f998SYi Kong MWPTY(2,I) = -I 548*1858f998SYi Kong MWPTX(3,I) = 6 - I 549*1858f998SYi Kong MWPTY(3,I) = I - 6 550*1858f998SYi Kong MWPTX(4,I) = I 551*1858f998SYi Kong MWPTY(4,I) = -I 552*1858f998SYi Kong MWPTX(6,I) = 6 - I 553*1858f998SYi Kong MWPTY(6,I) = I - 6 554*1858f998SYi Kong MWPTX(7,I) = -I 555*1858f998SYi Kong MWPTY(7,I) = I 556*1858f998SYi Kong MWPTX(8,I) = I - 6 557*1858f998SYi Kong MWPTY(8,I) = 6 - I 558*1858f998SYi Kong MWPTX(9,I) = -I 559*1858f998SYi Kong MWPTY(9,I) = I 560*1858f998SYi Kong MWPTX(11,I) = I - 6 561*1858f998SYi Kong MWPTY(11,I) = 6 - I 562*1858f998SYi Kong 160 CONTINUE 563*1858f998SYi Kong MWPTX(5,1) = 1 564*1858f998SYi Kong MWPTX(5,2) = 3 565*1858f998SYi Kong MWPTX(5,3) = 5 566*1858f998SYi Kong MWPTX(5,4) = 4 567*1858f998SYi Kong MWPTX(5,5) = 5 568*1858f998SYi Kong MWPTY(5,1) = -1 569*1858f998SYi Kong MWPTY(5,2) = 2 570*1858f998SYi Kong MWPTY(5,3) = -2 571*1858f998SYi Kong MWPTY(5,4) = 4 572*1858f998SYi Kong MWPTY(5,5) = -3 573*1858f998SYi Kong MWPTX(10,1) = -1 574*1858f998SYi Kong MWPTX(10,2) = -3 575*1858f998SYi Kong MWPTX(10,3) = -5 576*1858f998SYi Kong MWPTX(10,4) = 4 577*1858f998SYi Kong MWPTX(10,5) = 5 578*1858f998SYi Kong MWPTY(10,1) = 1 579*1858f998SYi Kong MWPTY(10,2) = 2 580*1858f998SYi Kong MWPTY(10,3) = 2 581*1858f998SYi Kong MWPTY(10,4) = 4 582*1858f998SYi Kong MWPTY(10,5) = 3 583*1858f998SYi Kong DO 200 I = 1, 11 584*1858f998SYi Kong INCX = MWPINX(I) 585*1858f998SYi Kong INCY = MWPINY(I) 586*1858f998SYi Kong DO 180 K = 1, 5 587*1858f998SYi Kong COPYX(K) = MWPX(K) 588*1858f998SYi Kong COPYY(K) = MWPY(K) 589*1858f998SYi Kong MWPSTX(K) = MWPTX(I,K) 590*1858f998SYi Kong MWPSTY(K) = MWPTY(I,K) 591*1858f998SYi Kong 180 CONTINUE 592*1858f998SYi Kong CALL SROTTEST(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I)) 593*1858f998SYi Kong CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC) 594*1858f998SYi Kong CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC) 595*1858f998SYi Kong 200 CONTINUE 596*1858f998SYi Kong RETURN 597*1858f998SYi Kong END 598*1858f998SYi Kong SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) 599*1858f998SYi Kong* ********************************* STEST ************************** 600*1858f998SYi Kong* 601*1858f998SYi Kong* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO 602*1858f998SYi Kong* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE 603*1858f998SYi Kong* NEGLIGIBLE. 604*1858f998SYi Kong* 605*1858f998SYi Kong* C. L. LAWSON, JPL, 1974 DEC 10 606*1858f998SYi Kong* 607*1858f998SYi Kong* .. Parameters .. 608*1858f998SYi Kong INTEGER NOUT 609*1858f998SYi Kong PARAMETER (NOUT=6) 610*1858f998SYi Kong* .. Scalar Arguments .. 611*1858f998SYi Kong REAL SFAC 612*1858f998SYi Kong INTEGER LEN 613*1858f998SYi Kong* .. Array Arguments .. 614*1858f998SYi Kong REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) 615*1858f998SYi Kong* .. Scalars in Common .. 616*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 617*1858f998SYi Kong LOGICAL PASS 618*1858f998SYi Kong* .. Local Scalars .. 619*1858f998SYi Kong REAL SD 620*1858f998SYi Kong INTEGER I 621*1858f998SYi Kong* .. External Functions .. 622*1858f998SYi Kong REAL SDIFF 623*1858f998SYi Kong EXTERNAL SDIFF 624*1858f998SYi Kong* .. Intrinsic Functions .. 625*1858f998SYi Kong INTRINSIC ABS 626*1858f998SYi Kong* .. Common blocks .. 627*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 628*1858f998SYi Kong* .. Executable Statements .. 629*1858f998SYi Kong* 630*1858f998SYi Kong DO 40 I = 1, LEN 631*1858f998SYi Kong SD = SCOMP(I) - STRUE(I) 632*1858f998SYi Kong IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0E0) 633*1858f998SYi Kong + GO TO 40 634*1858f998SYi Kong* 635*1858f998SYi Kong* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). 636*1858f998SYi Kong* 637*1858f998SYi Kong IF ( .NOT. PASS) GO TO 20 638*1858f998SYi Kong* PRINT FAIL MESSAGE AND HEADER. 639*1858f998SYi Kong PASS = .FALSE. 640*1858f998SYi Kong WRITE (NOUT,99999) 641*1858f998SYi Kong WRITE (NOUT,99998) 642*1858f998SYi Kong 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), 643*1858f998SYi Kong + STRUE(I), SD, SSIZE(I) 644*1858f998SYi Kong 40 CONTINUE 645*1858f998SYi Kong RETURN 646*1858f998SYi Kong* 647*1858f998SYi Kong99999 FORMAT (' FAIL') 648*1858f998SYi Kong99998 FORMAT (/' CASE N INCX INCY MODE I ', 649*1858f998SYi Kong + ' COMP(I) TRUE(I) DIFFERENCE', 650*1858f998SYi Kong + ' SIZE(I)',/1X) 651*1858f998SYi Kong99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4) 652*1858f998SYi Kong END 653*1858f998SYi Kong SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) 654*1858f998SYi Kong* ************************* STEST1 ***************************** 655*1858f998SYi Kong* 656*1858f998SYi Kong* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN 657*1858f998SYi Kong* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE 658*1858f998SYi Kong* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. 659*1858f998SYi Kong* 660*1858f998SYi Kong* C.L. LAWSON, JPL, 1978 DEC 6 661*1858f998SYi Kong* 662*1858f998SYi Kong* .. Scalar Arguments .. 663*1858f998SYi Kong REAL SCOMP1, SFAC, STRUE1 664*1858f998SYi Kong* .. Array Arguments .. 665*1858f998SYi Kong REAL SSIZE(*) 666*1858f998SYi Kong* .. Local Arrays .. 667*1858f998SYi Kong REAL SCOMP(1), STRUE(1) 668*1858f998SYi Kong* .. External Subroutines .. 669*1858f998SYi Kong EXTERNAL STEST 670*1858f998SYi Kong* .. Executable Statements .. 671*1858f998SYi Kong* 672*1858f998SYi Kong SCOMP(1) = SCOMP1 673*1858f998SYi Kong STRUE(1) = STRUE1 674*1858f998SYi Kong CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) 675*1858f998SYi Kong* 676*1858f998SYi Kong RETURN 677*1858f998SYi Kong END 678*1858f998SYi Kong REAL FUNCTION SDIFF(SA,SB) 679*1858f998SYi Kong* ********************************* SDIFF ************************** 680*1858f998SYi Kong* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 681*1858f998SYi Kong* 682*1858f998SYi Kong* .. Scalar Arguments .. 683*1858f998SYi Kong REAL SA, SB 684*1858f998SYi Kong* .. Executable Statements .. 685*1858f998SYi Kong SDIFF = SA - SB 686*1858f998SYi Kong RETURN 687*1858f998SYi Kong END 688*1858f998SYi Kong SUBROUTINE ITEST1(ICOMP,ITRUE) 689*1858f998SYi Kong* ********************************* ITEST1 ************************* 690*1858f998SYi Kong* 691*1858f998SYi Kong* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR 692*1858f998SYi Kong* EQUALITY. 693*1858f998SYi Kong* C. L. LAWSON, JPL, 1974 DEC 10 694*1858f998SYi Kong* 695*1858f998SYi Kong* .. Parameters .. 696*1858f998SYi Kong INTEGER NOUT 697*1858f998SYi Kong PARAMETER (NOUT=6) 698*1858f998SYi Kong* .. Scalar Arguments .. 699*1858f998SYi Kong INTEGER ICOMP, ITRUE 700*1858f998SYi Kong* .. Scalars in Common .. 701*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 702*1858f998SYi Kong LOGICAL PASS 703*1858f998SYi Kong* .. Local Scalars .. 704*1858f998SYi Kong INTEGER ID 705*1858f998SYi Kong* .. Common blocks .. 706*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 707*1858f998SYi Kong* .. Executable Statements .. 708*1858f998SYi Kong* 709*1858f998SYi Kong IF (ICOMP.EQ.ITRUE) GO TO 40 710*1858f998SYi Kong* 711*1858f998SYi Kong* HERE ICOMP IS NOT EQUAL TO ITRUE. 712*1858f998SYi Kong* 713*1858f998SYi Kong IF ( .NOT. PASS) GO TO 20 714*1858f998SYi Kong* PRINT FAIL MESSAGE AND HEADER. 715*1858f998SYi Kong PASS = .FALSE. 716*1858f998SYi Kong WRITE (NOUT,99999) 717*1858f998SYi Kong WRITE (NOUT,99998) 718*1858f998SYi Kong 20 ID = ICOMP - ITRUE 719*1858f998SYi Kong WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID 720*1858f998SYi Kong 40 CONTINUE 721*1858f998SYi Kong RETURN 722*1858f998SYi Kong* 723*1858f998SYi Kong99999 FORMAT (' FAIL') 724*1858f998SYi Kong99998 FORMAT (/' CASE N INCX INCY MODE ', 725*1858f998SYi Kong + ' COMP TRUE DIFFERENCE', 726*1858f998SYi Kong + /1X) 727*1858f998SYi Kong99997 FORMAT (1X,I4,I3,3I5,2I36,I12) 728*1858f998SYi Kong END 729