1*1858f998SYi Kong PROGRAM CCBLAT1 2*1858f998SYi Kong* Test program for the COMPLEX Level 1 CBLAS. 3*1858f998SYi Kong* Based upon the original CBLAS test routine together with: 4*1858f998SYi Kong* F06GAF 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 CHECK1, CHECK2, 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.LE.5) THEN 36*1858f998SYi Kong CALL CHECK2(SFAC) 37*1858f998SYi Kong ELSE IF (ICASE.GE.6) THEN 38*1858f998SYi Kong CALL CHECK1(SFAC) 39*1858f998SYi Kong END IF 40*1858f998SYi Kong* -- Print 41*1858f998SYi Kong IF (PASS) WRITE (NOUT,99998) 42*1858f998SYi Kong 20 CONTINUE 43*1858f998SYi Kong STOP 44*1858f998SYi Kong* 45*1858f998SYi Kong99999 FORMAT (' Complex CBLAS Test Program Results',/1X) 46*1858f998SYi Kong99998 FORMAT (' ----- PASS -----') 47*1858f998SYi Kong END 48*1858f998SYi Kong SUBROUTINE HEADER 49*1858f998SYi Kong* .. Parameters .. 50*1858f998SYi Kong INTEGER NOUT 51*1858f998SYi Kong PARAMETER (NOUT=6) 52*1858f998SYi Kong* .. Scalars in Common .. 53*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 54*1858f998SYi Kong LOGICAL PASS 55*1858f998SYi Kong* .. Local Arrays .. 56*1858f998SYi Kong CHARACTER*15 L(10) 57*1858f998SYi Kong* .. Common blocks .. 58*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 59*1858f998SYi Kong* .. Data statements .. 60*1858f998SYi Kong DATA L(1)/'CBLAS_CDOTC'/ 61*1858f998SYi Kong DATA L(2)/'CBLAS_CDOTU'/ 62*1858f998SYi Kong DATA L(3)/'CBLAS_CAXPY'/ 63*1858f998SYi Kong DATA L(4)/'CBLAS_CCOPY'/ 64*1858f998SYi Kong DATA L(5)/'CBLAS_CSWAP'/ 65*1858f998SYi Kong DATA L(6)/'CBLAS_SCNRM2'/ 66*1858f998SYi Kong DATA L(7)/'CBLAS_SCASUM'/ 67*1858f998SYi Kong DATA L(8)/'CBLAS_CSCAL'/ 68*1858f998SYi Kong DATA L(9)/'CBLAS_CSSCAL'/ 69*1858f998SYi Kong DATA L(10)/'CBLAS_ICAMAX'/ 70*1858f998SYi Kong* .. Executable Statements .. 71*1858f998SYi Kong WRITE (NOUT,99999) ICASE, L(ICASE) 72*1858f998SYi Kong RETURN 73*1858f998SYi Kong* 74*1858f998SYi Kong99999 FORMAT (/' Test of subprogram number',I3,9X,A15) 75*1858f998SYi Kong END 76*1858f998SYi Kong SUBROUTINE CHECK1(SFAC) 77*1858f998SYi Kong* .. Parameters .. 78*1858f998SYi Kong INTEGER NOUT 79*1858f998SYi Kong PARAMETER (NOUT=6) 80*1858f998SYi Kong* .. Scalar Arguments .. 81*1858f998SYi Kong REAL SFAC 82*1858f998SYi Kong* .. Scalars in Common .. 83*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 84*1858f998SYi Kong LOGICAL PASS 85*1858f998SYi Kong* .. Local Scalars .. 86*1858f998SYi Kong COMPLEX CA 87*1858f998SYi Kong REAL SA 88*1858f998SYi Kong INTEGER I, J, LEN, NP1 89*1858f998SYi Kong* .. Local Arrays .. 90*1858f998SYi Kong COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), 91*1858f998SYi Kong + MWPCS(5), MWPCT(5) 92*1858f998SYi Kong REAL STRUE2(5), STRUE4(5) 93*1858f998SYi Kong INTEGER ITRUE3(5) 94*1858f998SYi Kong* .. External Functions .. 95*1858f998SYi Kong REAL SCASUMTEST, SCNRM2TEST 96*1858f998SYi Kong INTEGER ICAMAXTEST 97*1858f998SYi Kong EXTERNAL SCASUMTEST, SCNRM2TEST, ICAMAXTEST 98*1858f998SYi Kong* .. External Subroutines .. 99*1858f998SYi Kong EXTERNAL CSCAL, CSSCALTEST, CTEST, ITEST1, STEST1 100*1858f998SYi Kong* .. Intrinsic Functions .. 101*1858f998SYi Kong INTRINSIC MAX 102*1858f998SYi Kong* .. Common blocks .. 103*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 104*1858f998SYi Kong* .. Data statements .. 105*1858f998SYi Kong DATA SA, CA/0.3E0, (0.4E0,-0.7E0)/ 106*1858f998SYi Kong DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 107*1858f998SYi Kong + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 108*1858f998SYi Kong + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 109*1858f998SYi Kong + (1.0E0,2.0E0), (0.3E0,-0.4E0), (3.0E0,4.0E0), 110*1858f998SYi Kong + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 111*1858f998SYi Kong + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 112*1858f998SYi Kong + (0.1E0,-0.3E0), (0.5E0,-0.1E0), (5.0E0,6.0E0), 113*1858f998SYi Kong + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 114*1858f998SYi Kong + (5.0E0,6.0E0), (5.0E0,6.0E0), (0.1E0,0.1E0), 115*1858f998SYi Kong + (-0.6E0,0.1E0), (0.1E0,-0.3E0), (7.0E0,8.0E0), 116*1858f998SYi Kong + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 117*1858f998SYi Kong + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.1E0,0.4E0), 118*1858f998SYi Kong + (0.4E0,0.1E0), (0.1E0,0.2E0), (2.0E0,3.0E0), 119*1858f998SYi Kong + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ 120*1858f998SYi Kong DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 121*1858f998SYi Kong + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 122*1858f998SYi Kong + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 123*1858f998SYi Kong + (4.0E0,5.0E0), (0.3E0,-0.4E0), (6.0E0,7.0E0), 124*1858f998SYi Kong + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 125*1858f998SYi Kong + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 126*1858f998SYi Kong + (0.1E0,-0.3E0), (8.0E0,9.0E0), (0.5E0,-0.1E0), 127*1858f998SYi Kong + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 128*1858f998SYi Kong + (2.0E0,5.0E0), (2.0E0,5.0E0), (0.1E0,0.1E0), 129*1858f998SYi Kong + (3.0E0,6.0E0), (-0.6E0,0.1E0), (4.0E0,7.0E0), 130*1858f998SYi Kong + (0.1E0,-0.3E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 131*1858f998SYi Kong + (7.0E0,2.0E0), (0.3E0,0.1E0), (5.0E0,8.0E0), 132*1858f998SYi Kong + (0.1E0,0.4E0), (6.0E0,9.0E0), (0.4E0,0.1E0), 133*1858f998SYi Kong + (8.0E0,3.0E0), (0.1E0,0.2E0), (9.0E0,4.0E0)/ 134*1858f998SYi Kong DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.7E0/ 135*1858f998SYi Kong DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.7E0/ 136*1858f998SYi Kong DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 137*1858f998SYi Kong + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 138*1858f998SYi Kong + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 139*1858f998SYi Kong + (1.0E0,2.0E0), (-0.16E0,-0.37E0), (3.0E0,4.0E0), 140*1858f998SYi Kong + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 141*1858f998SYi Kong + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 142*1858f998SYi Kong + (-0.17E0,-0.19E0), (0.13E0,-0.39E0), 143*1858f998SYi Kong + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 144*1858f998SYi Kong + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 145*1858f998SYi Kong + (0.11E0,-0.03E0), (-0.17E0,0.46E0), 146*1858f998SYi Kong + (-0.17E0,-0.19E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 147*1858f998SYi Kong + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 148*1858f998SYi Kong + (0.19E0,-0.17E0), (0.32E0,0.09E0), 149*1858f998SYi Kong + (0.23E0,-0.24E0), (0.18E0,0.01E0), 150*1858f998SYi Kong + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0), 151*1858f998SYi Kong + (2.0E0,3.0E0)/ 152*1858f998SYi Kong DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 153*1858f998SYi Kong + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 154*1858f998SYi Kong + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 155*1858f998SYi Kong + (4.0E0,5.0E0), (-0.16E0,-0.37E0), (6.0E0,7.0E0), 156*1858f998SYi Kong + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 157*1858f998SYi Kong + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 158*1858f998SYi Kong + (-0.17E0,-0.19E0), (8.0E0,9.0E0), 159*1858f998SYi Kong + (0.13E0,-0.39E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 160*1858f998SYi Kong + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 161*1858f998SYi Kong + (0.11E0,-0.03E0), (3.0E0,6.0E0), 162*1858f998SYi Kong + (-0.17E0,0.46E0), (4.0E0,7.0E0), 163*1858f998SYi Kong + (-0.17E0,-0.19E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 164*1858f998SYi Kong + (7.0E0,2.0E0), (0.19E0,-0.17E0), (5.0E0,8.0E0), 165*1858f998SYi Kong + (0.32E0,0.09E0), (6.0E0,9.0E0), 166*1858f998SYi Kong + (0.23E0,-0.24E0), (8.0E0,3.0E0), 167*1858f998SYi Kong + (0.18E0,0.01E0), (9.0E0,4.0E0)/ 168*1858f998SYi Kong DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 169*1858f998SYi Kong + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 170*1858f998SYi Kong + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 171*1858f998SYi Kong + (1.0E0,2.0E0), (0.09E0,-0.12E0), (3.0E0,4.0E0), 172*1858f998SYi Kong + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 173*1858f998SYi Kong + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 174*1858f998SYi Kong + (0.03E0,-0.09E0), (0.15E0,-0.03E0), 175*1858f998SYi Kong + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 176*1858f998SYi Kong + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 177*1858f998SYi Kong + (0.03E0,0.03E0), (-0.18E0,0.03E0), 178*1858f998SYi Kong + (0.03E0,-0.09E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 179*1858f998SYi Kong + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 180*1858f998SYi Kong + (0.09E0,0.03E0), (0.03E0,0.12E0), 181*1858f998SYi Kong + (0.12E0,0.03E0), (0.03E0,0.06E0), (2.0E0,3.0E0), 182*1858f998SYi Kong + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ 183*1858f998SYi Kong DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 184*1858f998SYi Kong + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 185*1858f998SYi Kong + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 186*1858f998SYi Kong + (4.0E0,5.0E0), (0.09E0,-0.12E0), (6.0E0,7.0E0), 187*1858f998SYi Kong + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 188*1858f998SYi Kong + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 189*1858f998SYi Kong + (0.03E0,-0.09E0), (8.0E0,9.0E0), 190*1858f998SYi Kong + (0.15E0,-0.03E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 191*1858f998SYi Kong + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 192*1858f998SYi Kong + (0.03E0,0.03E0), (3.0E0,6.0E0), 193*1858f998SYi Kong + (-0.18E0,0.03E0), (4.0E0,7.0E0), 194*1858f998SYi Kong + (0.03E0,-0.09E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 195*1858f998SYi Kong + (7.0E0,2.0E0), (0.09E0,0.03E0), (5.0E0,8.0E0), 196*1858f998SYi Kong + (0.03E0,0.12E0), (6.0E0,9.0E0), (0.12E0,0.03E0), 197*1858f998SYi Kong + (8.0E0,3.0E0), (0.03E0,0.06E0), (9.0E0,4.0E0)/ 198*1858f998SYi Kong DATA ITRUE3/0, 1, 2, 2, 2/ 199*1858f998SYi Kong* .. Executable Statements .. 200*1858f998SYi Kong DO 60 INCX = 1, 2 201*1858f998SYi Kong DO 40 NP1 = 1, 5 202*1858f998SYi Kong N = NP1 - 1 203*1858f998SYi Kong LEN = 2*MAX(N,1) 204*1858f998SYi Kong* .. Set vector arguments .. 205*1858f998SYi Kong DO 20 I = 1, LEN 206*1858f998SYi Kong CX(I) = CV(I,NP1,INCX) 207*1858f998SYi Kong 20 CONTINUE 208*1858f998SYi Kong IF (ICASE.EQ.6) THEN 209*1858f998SYi Kong* .. SCNRM2TEST .. 210*1858f998SYi Kong CALL STEST1(SCNRM2TEST(N,CX,INCX),STRUE2(NP1), 211*1858f998SYi Kong + STRUE2(NP1), SFAC) 212*1858f998SYi Kong ELSE IF (ICASE.EQ.7) THEN 213*1858f998SYi Kong* .. SCASUMTEST .. 214*1858f998SYi Kong CALL STEST1(SCASUMTEST(N,CX,INCX),STRUE4(NP1), 215*1858f998SYi Kong + STRUE4(NP1),SFAC) 216*1858f998SYi Kong ELSE IF (ICASE.EQ.8) THEN 217*1858f998SYi Kong* .. CSCAL .. 218*1858f998SYi Kong CALL CSCAL(N,CA,CX,INCX) 219*1858f998SYi Kong CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), 220*1858f998SYi Kong + SFAC) 221*1858f998SYi Kong ELSE IF (ICASE.EQ.9) THEN 222*1858f998SYi Kong* .. CSSCALTEST .. 223*1858f998SYi Kong CALL CSSCALTEST(N,SA,CX,INCX) 224*1858f998SYi Kong CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), 225*1858f998SYi Kong + SFAC) 226*1858f998SYi Kong ELSE IF (ICASE.EQ.10) THEN 227*1858f998SYi Kong* .. ICAMAXTEST .. 228*1858f998SYi Kong CALL ITEST1(ICAMAXTEST(N,CX,INCX),ITRUE3(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* 234*1858f998SYi Kong 40 CONTINUE 235*1858f998SYi Kong 60 CONTINUE 236*1858f998SYi Kong* 237*1858f998SYi Kong INCX = 1 238*1858f998SYi Kong IF (ICASE.EQ.8) THEN 239*1858f998SYi Kong* CSCAL 240*1858f998SYi Kong* Add a test for alpha equal to zero. 241*1858f998SYi Kong CA = (0.0E0,0.0E0) 242*1858f998SYi Kong DO 80 I = 1, 5 243*1858f998SYi Kong MWPCT(I) = (0.0E0,0.0E0) 244*1858f998SYi Kong MWPCS(I) = (1.0E0,1.0E0) 245*1858f998SYi Kong 80 CONTINUE 246*1858f998SYi Kong CALL CSCAL(5,CA,CX,INCX) 247*1858f998SYi Kong CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 248*1858f998SYi Kong ELSE IF (ICASE.EQ.9) THEN 249*1858f998SYi Kong* CSSCALTEST 250*1858f998SYi Kong* Add a test for alpha equal to zero. 251*1858f998SYi Kong SA = 0.0E0 252*1858f998SYi Kong DO 100 I = 1, 5 253*1858f998SYi Kong MWPCT(I) = (0.0E0,0.0E0) 254*1858f998SYi Kong MWPCS(I) = (1.0E0,1.0E0) 255*1858f998SYi Kong 100 CONTINUE 256*1858f998SYi Kong CALL CSSCALTEST(5,SA,CX,INCX) 257*1858f998SYi Kong CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 258*1858f998SYi Kong* Add a test for alpha equal to one. 259*1858f998SYi Kong SA = 1.0E0 260*1858f998SYi Kong DO 120 I = 1, 5 261*1858f998SYi Kong MWPCT(I) = CX(I) 262*1858f998SYi Kong MWPCS(I) = CX(I) 263*1858f998SYi Kong 120 CONTINUE 264*1858f998SYi Kong CALL CSSCALTEST(5,SA,CX,INCX) 265*1858f998SYi Kong CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 266*1858f998SYi Kong* Add a test for alpha equal to minus one. 267*1858f998SYi Kong SA = -1.0E0 268*1858f998SYi Kong DO 140 I = 1, 5 269*1858f998SYi Kong MWPCT(I) = -CX(I) 270*1858f998SYi Kong MWPCS(I) = -CX(I) 271*1858f998SYi Kong 140 CONTINUE 272*1858f998SYi Kong CALL CSSCALTEST(5,SA,CX,INCX) 273*1858f998SYi Kong CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 274*1858f998SYi Kong END IF 275*1858f998SYi Kong RETURN 276*1858f998SYi Kong END 277*1858f998SYi Kong SUBROUTINE CHECK2(SFAC) 278*1858f998SYi Kong* .. Parameters .. 279*1858f998SYi Kong INTEGER NOUT 280*1858f998SYi Kong PARAMETER (NOUT=6) 281*1858f998SYi Kong* .. Scalar Arguments .. 282*1858f998SYi Kong REAL SFAC 283*1858f998SYi Kong* .. Scalars in Common .. 284*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 285*1858f998SYi Kong LOGICAL PASS 286*1858f998SYi Kong* .. Local Scalars .. 287*1858f998SYi Kong COMPLEX CA,CTEMP 288*1858f998SYi Kong INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY 289*1858f998SYi Kong* .. Local Arrays .. 290*1858f998SYi Kong COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14), 291*1858f998SYi Kong + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4), 292*1858f998SYi Kong + CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7) 293*1858f998SYi Kong INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) 294*1858f998SYi Kong* .. External Functions .. 295*1858f998SYi Kong EXTERNAL CDOTCTEST, CDOTUTEST 296*1858f998SYi Kong* .. External Subroutines .. 297*1858f998SYi Kong EXTERNAL CAXPYTEST, CCOPYTEST, CSWAPTEST, CTEST 298*1858f998SYi Kong* .. Intrinsic Functions .. 299*1858f998SYi Kong INTRINSIC ABS, MIN 300*1858f998SYi Kong* .. Common blocks .. 301*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 302*1858f998SYi Kong* .. Data statements .. 303*1858f998SYi Kong DATA CA/(0.4E0,-0.7E0)/ 304*1858f998SYi Kong DATA INCXS/1, 2, -2, -1/ 305*1858f998SYi Kong DATA INCYS/1, -2, 1, -2/ 306*1858f998SYi Kong DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ 307*1858f998SYi Kong DATA NS/0, 1, 2, 4/ 308*1858f998SYi Kong DATA CX1/(0.7E0,-0.8E0), (-0.4E0,-0.7E0), 309*1858f998SYi Kong + (-0.1E0,-0.9E0), (0.2E0,-0.8E0), 310*1858f998SYi Kong + (-0.9E0,-0.4E0), (0.1E0,0.4E0), (-0.6E0,0.6E0)/ 311*1858f998SYi Kong DATA CY1/(0.6E0,-0.6E0), (-0.9E0,0.5E0), 312*1858f998SYi Kong + (0.7E0,-0.6E0), (0.1E0,-0.5E0), (-0.1E0,-0.2E0), 313*1858f998SYi Kong + (-0.5E0,-0.3E0), (0.8E0,-0.7E0)/ 314*1858f998SYi Kong DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), 315*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 316*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 317*1858f998SYi Kong + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 318*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 319*1858f998SYi Kong + (0.0E0,0.0E0), (0.32E0,-1.41E0), 320*1858f998SYi Kong + (-1.55E0,0.5E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 321*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 322*1858f998SYi Kong + (0.32E0,-1.41E0), (-1.55E0,0.5E0), 323*1858f998SYi Kong + (0.03E0,-0.89E0), (-0.38E0,-0.96E0), 324*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 325*1858f998SYi Kong DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), 326*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 327*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 328*1858f998SYi Kong + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 329*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 330*1858f998SYi Kong + (0.0E0,0.0E0), (-0.07E0,-0.89E0), 331*1858f998SYi Kong + (-0.9E0,0.5E0), (0.42E0,-1.41E0), (0.0E0,0.0E0), 332*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 333*1858f998SYi Kong + (0.78E0,0.06E0), (-0.9E0,0.5E0), 334*1858f998SYi Kong + (0.06E0,-0.13E0), (0.1E0,-0.5E0), 335*1858f998SYi Kong + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), 336*1858f998SYi Kong + (0.52E0,-1.51E0)/ 337*1858f998SYi Kong DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), 338*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 339*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 340*1858f998SYi Kong + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 341*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 342*1858f998SYi Kong + (0.0E0,0.0E0), (-0.07E0,-0.89E0), 343*1858f998SYi Kong + (-1.18E0,-0.31E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 344*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 345*1858f998SYi Kong + (0.78E0,0.06E0), (-1.54E0,0.97E0), 346*1858f998SYi Kong + (0.03E0,-0.89E0), (-0.18E0,-1.31E0), 347*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 348*1858f998SYi Kong DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), 349*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 350*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 351*1858f998SYi Kong + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 352*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 353*1858f998SYi Kong + (0.0E0,0.0E0), (0.32E0,-1.41E0), (-0.9E0,0.5E0), 354*1858f998SYi Kong + (0.05E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 355*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.32E0,-1.41E0), 356*1858f998SYi Kong + (-0.9E0,0.5E0), (0.05E0,-0.6E0), (0.1E0,-0.5E0), 357*1858f998SYi Kong + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), 358*1858f998SYi Kong + (0.32E0,-1.16E0)/ 359*1858f998SYi Kong DATA CT7/(0.0E0,0.0E0), (-0.06E0,-0.90E0), 360*1858f998SYi Kong + (0.65E0,-0.47E0), (-0.34E0,-1.22E0), 361*1858f998SYi Kong + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 362*1858f998SYi Kong + (-0.59E0,-1.46E0), (-1.04E0,-0.04E0), 363*1858f998SYi Kong + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 364*1858f998SYi Kong + (-0.83E0,0.59E0), (0.07E0,-0.37E0), 365*1858f998SYi Kong + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 366*1858f998SYi Kong + (-0.76E0,-1.15E0), (-1.33E0,-1.82E0)/ 367*1858f998SYi Kong DATA CT6/(0.0E0,0.0E0), (0.90E0,0.06E0), 368*1858f998SYi Kong + (0.91E0,-0.77E0), (1.80E0,-0.10E0), 369*1858f998SYi Kong + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.45E0,0.74E0), 370*1858f998SYi Kong + (0.20E0,0.90E0), (0.0E0,0.0E0), (0.90E0,0.06E0), 371*1858f998SYi Kong + (-0.55E0,0.23E0), (0.83E0,-0.39E0), 372*1858f998SYi Kong + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.04E0,0.79E0), 373*1858f998SYi Kong + (1.95E0,1.22E0)/ 374*1858f998SYi Kong DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7E0,-0.8E0), 375*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 376*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 377*1858f998SYi Kong + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 378*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 379*1858f998SYi Kong + (0.0E0,0.0E0), (0.6E0,-0.6E0), (-0.9E0,0.5E0), 380*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 381*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), 382*1858f998SYi Kong + (-0.9E0,0.5E0), (0.7E0,-0.6E0), (0.1E0,-0.5E0), 383*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 384*1858f998SYi Kong DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7E0,-0.8E0), 385*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 386*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 387*1858f998SYi Kong + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 388*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 389*1858f998SYi Kong + (0.0E0,0.0E0), (0.7E0,-0.6E0), (-0.4E0,-0.7E0), 390*1858f998SYi Kong + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 391*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.8E0,-0.7E0), 392*1858f998SYi Kong + (-0.4E0,-0.7E0), (-0.1E0,-0.2E0), 393*1858f998SYi Kong + (0.2E0,-0.8E0), (0.7E0,-0.6E0), (0.1E0,0.4E0), 394*1858f998SYi Kong + (0.6E0,-0.6E0)/ 395*1858f998SYi Kong DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7E0,-0.8E0), 396*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 397*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 398*1858f998SYi Kong + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 399*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 400*1858f998SYi Kong + (0.0E0,0.0E0), (-0.9E0,0.5E0), (-0.4E0,-0.7E0), 401*1858f998SYi Kong + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 402*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.1E0,-0.5E0), 403*1858f998SYi Kong + (-0.4E0,-0.7E0), (0.7E0,-0.6E0), (0.2E0,-0.8E0), 404*1858f998SYi Kong + (-0.9E0,0.5E0), (0.1E0,0.4E0), (0.6E0,-0.6E0)/ 405*1858f998SYi Kong DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7E0,-0.8E0), 406*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 407*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 408*1858f998SYi Kong + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 409*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 410*1858f998SYi Kong + (0.0E0,0.0E0), (0.6E0,-0.6E0), (0.7E0,-0.6E0), 411*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 412*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), 413*1858f998SYi Kong + (0.7E0,-0.6E0), (-0.1E0,-0.2E0), (0.8E0,-0.7E0), 414*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 415*1858f998SYi Kong DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), 416*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 417*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 418*1858f998SYi Kong + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 419*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 420*1858f998SYi Kong + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.4E0,-0.7E0), 421*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 422*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), 423*1858f998SYi Kong + (-0.4E0,-0.7E0), (-0.1E0,-0.9E0), 424*1858f998SYi Kong + (0.2E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 425*1858f998SYi Kong + (0.0E0,0.0E0)/ 426*1858f998SYi Kong DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), 427*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 428*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 429*1858f998SYi Kong + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 430*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 431*1858f998SYi Kong + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (-0.9E0,0.5E0), 432*1858f998SYi Kong + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 433*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), 434*1858f998SYi Kong + (-0.9E0,0.5E0), (-0.9E0,-0.4E0), (0.1E0,-0.5E0), 435*1858f998SYi Kong + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), 436*1858f998SYi Kong + (0.7E0,-0.8E0)/ 437*1858f998SYi Kong DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), 438*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 439*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 440*1858f998SYi Kong + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 441*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 442*1858f998SYi Kong + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (0.7E0,-0.8E0), 443*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 444*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), 445*1858f998SYi Kong + (-0.9E0,-0.4E0), (-0.1E0,-0.9E0), 446*1858f998SYi Kong + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 447*1858f998SYi Kong + (0.0E0,0.0E0)/ 448*1858f998SYi Kong DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), 449*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 450*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 451*1858f998SYi Kong + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 452*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 453*1858f998SYi Kong + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.9E0,0.5E0), 454*1858f998SYi Kong + (-0.4E0,-0.7E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 455*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), 456*1858f998SYi Kong + (-0.9E0,0.5E0), (-0.4E0,-0.7E0), (0.1E0,-0.5E0), 457*1858f998SYi Kong + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), 458*1858f998SYi Kong + (0.2E0,-0.8E0)/ 459*1858f998SYi Kong DATA CSIZE1/(0.0E0,0.0E0), (0.9E0,0.9E0), 460*1858f998SYi Kong + (1.63E0,1.73E0), (2.90E0,2.78E0)/ 461*1858f998SYi Kong DATA CSIZE3/(0.0E0,0.0E0), (0.0E0,0.0E0), 462*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 463*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.17E0,1.17E0), 464*1858f998SYi Kong + (1.17E0,1.17E0), (1.17E0,1.17E0), 465*1858f998SYi Kong + (1.17E0,1.17E0), (1.17E0,1.17E0), 466*1858f998SYi Kong + (1.17E0,1.17E0), (1.17E0,1.17E0)/ 467*1858f998SYi Kong DATA CSIZE2/(0.0E0,0.0E0), (0.0E0,0.0E0), 468*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 469*1858f998SYi Kong + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.54E0,1.54E0), 470*1858f998SYi Kong + (1.54E0,1.54E0), (1.54E0,1.54E0), 471*1858f998SYi Kong + (1.54E0,1.54E0), (1.54E0,1.54E0), 472*1858f998SYi Kong + (1.54E0,1.54E0), (1.54E0,1.54E0)/ 473*1858f998SYi Kong* .. Executable Statements .. 474*1858f998SYi Kong DO 60 KI = 1, 4 475*1858f998SYi Kong INCX = INCXS(KI) 476*1858f998SYi Kong INCY = INCYS(KI) 477*1858f998SYi Kong MX = ABS(INCX) 478*1858f998SYi Kong MY = ABS(INCY) 479*1858f998SYi Kong* 480*1858f998SYi Kong DO 40 KN = 1, 4 481*1858f998SYi Kong N = NS(KN) 482*1858f998SYi Kong KSIZE = MIN(2,KN) 483*1858f998SYi Kong LENX = LENS(KN,MX) 484*1858f998SYi Kong LENY = LENS(KN,MY) 485*1858f998SYi Kong* .. initialize all argument arrays .. 486*1858f998SYi Kong DO 20 I = 1, 7 487*1858f998SYi Kong CX(I) = CX1(I) 488*1858f998SYi Kong CY(I) = CY1(I) 489*1858f998SYi Kong 20 CONTINUE 490*1858f998SYi Kong IF (ICASE.EQ.1) THEN 491*1858f998SYi Kong* .. CDOTCTEST .. 492*1858f998SYi Kong CALL CDOTCTEST(N,CX,INCX,CY,INCY,CTEMP) 493*1858f998SYi Kong CDOT(1) = CTEMP 494*1858f998SYi Kong CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) 495*1858f998SYi Kong ELSE IF (ICASE.EQ.2) THEN 496*1858f998SYi Kong* .. CDOTUTEST .. 497*1858f998SYi Kong CALL CDOTUTEST(N,CX,INCX,CY,INCY,CTEMP) 498*1858f998SYi Kong CDOT(1) = CTEMP 499*1858f998SYi Kong CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) 500*1858f998SYi Kong ELSE IF (ICASE.EQ.3) THEN 501*1858f998SYi Kong* .. CAXPYTEST .. 502*1858f998SYi Kong CALL CAXPYTEST(N,CA,CX,INCX,CY,INCY) 503*1858f998SYi Kong CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) 504*1858f998SYi Kong ELSE IF (ICASE.EQ.4) THEN 505*1858f998SYi Kong* .. CCOPYTEST .. 506*1858f998SYi Kong CALL CCOPYTEST(N,CX,INCX,CY,INCY) 507*1858f998SYi Kong CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) 508*1858f998SYi Kong ELSE IF (ICASE.EQ.5) THEN 509*1858f998SYi Kong* .. CSWAPTEST .. 510*1858f998SYi Kong CALL CSWAPTEST(N,CX,INCX,CY,INCY) 511*1858f998SYi Kong CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0E0) 512*1858f998SYi Kong CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) 513*1858f998SYi Kong ELSE 514*1858f998SYi Kong WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' 515*1858f998SYi Kong STOP 516*1858f998SYi Kong END IF 517*1858f998SYi Kong* 518*1858f998SYi Kong 40 CONTINUE 519*1858f998SYi Kong 60 CONTINUE 520*1858f998SYi Kong RETURN 521*1858f998SYi Kong END 522*1858f998SYi Kong SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) 523*1858f998SYi Kong* ********************************* STEST ************************** 524*1858f998SYi Kong* 525*1858f998SYi Kong* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO 526*1858f998SYi Kong* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE 527*1858f998SYi Kong* NEGLIGIBLE. 528*1858f998SYi Kong* 529*1858f998SYi Kong* C. L. LAWSON, JPL, 1974 DEC 10 530*1858f998SYi Kong* 531*1858f998SYi Kong* .. Parameters .. 532*1858f998SYi Kong INTEGER NOUT 533*1858f998SYi Kong PARAMETER (NOUT=6) 534*1858f998SYi Kong* .. Scalar Arguments .. 535*1858f998SYi Kong REAL SFAC 536*1858f998SYi Kong INTEGER LEN 537*1858f998SYi Kong* .. Array Arguments .. 538*1858f998SYi Kong REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) 539*1858f998SYi Kong* .. Scalars in Common .. 540*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 541*1858f998SYi Kong LOGICAL PASS 542*1858f998SYi Kong* .. Local Scalars .. 543*1858f998SYi Kong REAL SD 544*1858f998SYi Kong INTEGER I 545*1858f998SYi Kong* .. External Functions .. 546*1858f998SYi Kong REAL SDIFF 547*1858f998SYi Kong EXTERNAL SDIFF 548*1858f998SYi Kong* .. Intrinsic Functions .. 549*1858f998SYi Kong INTRINSIC ABS 550*1858f998SYi Kong* .. Common blocks .. 551*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 552*1858f998SYi Kong* .. Executable Statements .. 553*1858f998SYi Kong* 554*1858f998SYi Kong DO 40 I = 1, LEN 555*1858f998SYi Kong SD = SCOMP(I) - STRUE(I) 556*1858f998SYi Kong IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0E0) 557*1858f998SYi Kong + GO TO 40 558*1858f998SYi Kong* 559*1858f998SYi Kong* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). 560*1858f998SYi Kong* 561*1858f998SYi Kong IF ( .NOT. PASS) GO TO 20 562*1858f998SYi Kong* PRINT FAIL MESSAGE AND HEADER. 563*1858f998SYi Kong PASS = .FALSE. 564*1858f998SYi Kong WRITE (NOUT,99999) 565*1858f998SYi Kong WRITE (NOUT,99998) 566*1858f998SYi Kong 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), 567*1858f998SYi Kong + STRUE(I), SD, SSIZE(I) 568*1858f998SYi Kong 40 CONTINUE 569*1858f998SYi Kong RETURN 570*1858f998SYi Kong* 571*1858f998SYi Kong99999 FORMAT (' FAIL') 572*1858f998SYi Kong99998 FORMAT (/' CASE N INCX INCY MODE I ', 573*1858f998SYi Kong + ' COMP(I) TRUE(I) DIFFERENCE', 574*1858f998SYi Kong + ' SIZE(I)',/1X) 575*1858f998SYi Kong99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4) 576*1858f998SYi Kong END 577*1858f998SYi Kong SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) 578*1858f998SYi Kong* ************************* STEST1 ***************************** 579*1858f998SYi Kong* 580*1858f998SYi Kong* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN 581*1858f998SYi Kong* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE 582*1858f998SYi Kong* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. 583*1858f998SYi Kong* 584*1858f998SYi Kong* C.L. LAWSON, JPL, 1978 DEC 6 585*1858f998SYi Kong* 586*1858f998SYi Kong* .. Scalar Arguments .. 587*1858f998SYi Kong REAL SCOMP1, SFAC, STRUE1 588*1858f998SYi Kong* .. Array Arguments .. 589*1858f998SYi Kong REAL SSIZE(*) 590*1858f998SYi Kong* .. Local Arrays .. 591*1858f998SYi Kong REAL SCOMP(1), STRUE(1) 592*1858f998SYi Kong* .. External Subroutines .. 593*1858f998SYi Kong EXTERNAL STEST 594*1858f998SYi Kong* .. Executable Statements .. 595*1858f998SYi Kong* 596*1858f998SYi Kong SCOMP(1) = SCOMP1 597*1858f998SYi Kong STRUE(1) = STRUE1 598*1858f998SYi Kong CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) 599*1858f998SYi Kong* 600*1858f998SYi Kong RETURN 601*1858f998SYi Kong END 602*1858f998SYi Kong REAL FUNCTION SDIFF(SA,SB) 603*1858f998SYi Kong* ********************************* SDIFF ************************** 604*1858f998SYi Kong* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 605*1858f998SYi Kong* 606*1858f998SYi Kong* .. Scalar Arguments .. 607*1858f998SYi Kong REAL SA, SB 608*1858f998SYi Kong* .. Executable Statements .. 609*1858f998SYi Kong SDIFF = SA - SB 610*1858f998SYi Kong RETURN 611*1858f998SYi Kong END 612*1858f998SYi Kong SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC) 613*1858f998SYi Kong* **************************** CTEST ***************************** 614*1858f998SYi Kong* 615*1858f998SYi Kong* C.L. LAWSON, JPL, 1978 DEC 6 616*1858f998SYi Kong* 617*1858f998SYi Kong* .. Scalar Arguments .. 618*1858f998SYi Kong REAL SFAC 619*1858f998SYi Kong INTEGER LEN 620*1858f998SYi Kong* .. Array Arguments .. 621*1858f998SYi Kong COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN) 622*1858f998SYi Kong* .. Local Scalars .. 623*1858f998SYi Kong INTEGER I 624*1858f998SYi Kong* .. Local Arrays .. 625*1858f998SYi Kong REAL SCOMP(20), SSIZE(20), STRUE(20) 626*1858f998SYi Kong* .. External Subroutines .. 627*1858f998SYi Kong EXTERNAL STEST 628*1858f998SYi Kong* .. Intrinsic Functions .. 629*1858f998SYi Kong INTRINSIC AIMAG, REAL 630*1858f998SYi Kong* .. Executable Statements .. 631*1858f998SYi Kong DO 20 I = 1, LEN 632*1858f998SYi Kong SCOMP(2*I-1) = REAL(CCOMP(I)) 633*1858f998SYi Kong SCOMP(2*I) = AIMAG(CCOMP(I)) 634*1858f998SYi Kong STRUE(2*I-1) = REAL(CTRUE(I)) 635*1858f998SYi Kong STRUE(2*I) = AIMAG(CTRUE(I)) 636*1858f998SYi Kong SSIZE(2*I-1) = REAL(CSIZE(I)) 637*1858f998SYi Kong SSIZE(2*I) = AIMAG(CSIZE(I)) 638*1858f998SYi Kong 20 CONTINUE 639*1858f998SYi Kong* 640*1858f998SYi Kong CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC) 641*1858f998SYi Kong RETURN 642*1858f998SYi Kong END 643*1858f998SYi Kong SUBROUTINE ITEST1(ICOMP,ITRUE) 644*1858f998SYi Kong* ********************************* ITEST1 ************************* 645*1858f998SYi Kong* 646*1858f998SYi Kong* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR 647*1858f998SYi Kong* EQUALITY. 648*1858f998SYi Kong* C. L. LAWSON, JPL, 1974 DEC 10 649*1858f998SYi Kong* 650*1858f998SYi Kong* .. Parameters .. 651*1858f998SYi Kong INTEGER NOUT 652*1858f998SYi Kong PARAMETER (NOUT=6) 653*1858f998SYi Kong* .. Scalar Arguments .. 654*1858f998SYi Kong INTEGER ICOMP, ITRUE 655*1858f998SYi Kong* .. Scalars in Common .. 656*1858f998SYi Kong INTEGER ICASE, INCX, INCY, MODE, N 657*1858f998SYi Kong LOGICAL PASS 658*1858f998SYi Kong* .. Local Scalars .. 659*1858f998SYi Kong INTEGER ID 660*1858f998SYi Kong* .. Common blocks .. 661*1858f998SYi Kong COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 662*1858f998SYi Kong* .. Executable Statements .. 663*1858f998SYi Kong IF (ICOMP.EQ.ITRUE) GO TO 40 664*1858f998SYi Kong* 665*1858f998SYi Kong* HERE ICOMP IS NOT EQUAL TO ITRUE. 666*1858f998SYi Kong* 667*1858f998SYi Kong IF ( .NOT. PASS) GO TO 20 668*1858f998SYi Kong* PRINT FAIL MESSAGE AND HEADER. 669*1858f998SYi Kong PASS = .FALSE. 670*1858f998SYi Kong WRITE (NOUT,99999) 671*1858f998SYi Kong WRITE (NOUT,99998) 672*1858f998SYi Kong 20 ID = ICOMP - ITRUE 673*1858f998SYi Kong WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID 674*1858f998SYi Kong 40 CONTINUE 675*1858f998SYi Kong RETURN 676*1858f998SYi Kong* 677*1858f998SYi Kong99999 FORMAT (' FAIL') 678*1858f998SYi Kong99998 FORMAT (/' CASE N INCX INCY MODE ', 679*1858f998SYi Kong + ' COMP TRUE DIFFERENCE', 680*1858f998SYi Kong + /1X) 681*1858f998SYi Kong99997 FORMAT (1X,I4,I3,3I5,2I36,I12) 682*1858f998SYi Kong END 683