|
LAPACK 3.3.0
|
|
LAPACK 3.3.0
|
00001 PROGRAM SBLAT1 00002 * Test program for the REAL Level 1 BLAS. 00003 * Based upon the original BLAS test routine together with: 00004 * F06EAF Example Program Text 00005 * .. Parameters .. 00006 INTEGER NOUT 00007 PARAMETER (NOUT=6) 00008 * .. Scalars in Common .. 00009 INTEGER ICASE, INCX, INCY, MODE, N 00010 LOGICAL PASS 00011 * .. Local Scalars .. 00012 REAL SFAC 00013 INTEGER IC 00014 * .. External Subroutines .. 00015 EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER 00016 * .. Common blocks .. 00017 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00018 * .. Data statements .. 00019 DATA SFAC/9.765625E-4/ 00020 * .. Executable Statements .. 00021 WRITE (NOUT,99999) 00022 DO 20 IC = 1, 10 00023 ICASE = IC 00024 CALL HEADER 00025 * 00026 * .. Initialize PASS, INCX, INCY, and MODE for a new case. .. 00027 * .. the value 9999 for INCX, INCY or MODE will appear in the .. 00028 * .. detailed output, if any, for cases that do not involve .. 00029 * .. these parameters .. 00030 * 00031 PASS = .TRUE. 00032 INCX = 9999 00033 INCY = 9999 00034 MODE = 9999 00035 IF (ICASE.EQ.3) THEN 00036 CALL CHECK0(SFAC) 00037 ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR. 00038 + ICASE.EQ.10) THEN 00039 CALL CHECK1(SFAC) 00040 ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR. 00041 + ICASE.EQ.6) THEN 00042 CALL CHECK2(SFAC) 00043 ELSE IF (ICASE.EQ.4) THEN 00044 CALL CHECK3(SFAC) 00045 END IF 00046 * -- Print 00047 IF (PASS) WRITE (NOUT,99998) 00048 20 CONTINUE 00049 STOP 00050 * 00051 99999 FORMAT (' Real BLAS Test Program Results',/1X) 00052 99998 FORMAT (' ----- PASS -----') 00053 END 00054 SUBROUTINE HEADER 00055 * .. Parameters .. 00056 INTEGER NOUT 00057 PARAMETER (NOUT=6) 00058 * .. Scalars in Common .. 00059 INTEGER ICASE, INCX, INCY, MODE, N 00060 LOGICAL PASS 00061 * .. Local Arrays .. 00062 CHARACTER*6 L(10) 00063 * .. Common blocks .. 00064 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00065 * .. Data statements .. 00066 DATA L(1)/' SDOT '/ 00067 DATA L(2)/'SAXPY '/ 00068 DATA L(3)/'SROTG '/ 00069 DATA L(4)/' SROT '/ 00070 DATA L(5)/'SCOPY '/ 00071 DATA L(6)/'SSWAP '/ 00072 DATA L(7)/'SNRM2 '/ 00073 DATA L(8)/'SASUM '/ 00074 DATA L(9)/'SSCAL '/ 00075 DATA L(10)/'ISAMAX'/ 00076 * .. Executable Statements .. 00077 WRITE (NOUT,99999) ICASE, L(ICASE) 00078 RETURN 00079 * 00080 99999 FORMAT (/' Test of subprogram number',I3,12X,A6) 00081 END 00082 SUBROUTINE CHECK0(SFAC) 00083 * .. Parameters .. 00084 INTEGER NOUT 00085 PARAMETER (NOUT=6) 00086 * .. Scalar Arguments .. 00087 REAL SFAC 00088 * .. Scalars in Common .. 00089 INTEGER ICASE, INCX, INCY, MODE, N 00090 LOGICAL PASS 00091 * .. Local Scalars .. 00092 REAL D12, SA, SB, SC, SS 00093 INTEGER K 00094 * .. Local Arrays .. 00095 REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8), 00096 + DS1(8) 00097 * .. External Subroutines .. 00098 EXTERNAL SROTG, STEST1 00099 * .. Common blocks .. 00100 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00101 * .. Data statements .. 00102 DATA DA1/0.3E0, 0.4E0, -0.3E0, -0.4E0, -0.3E0, 0.0E0, 00103 + 0.0E0, 1.0E0/ 00104 DATA DB1/0.4E0, 0.3E0, 0.4E0, 0.3E0, -0.4E0, 0.0E0, 00105 + 1.0E0, 0.0E0/ 00106 DATA DC1/0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.6E0, 1.0E0, 00107 + 0.0E0, 1.0E0/ 00108 DATA DS1/0.8E0, 0.6E0, 0.8E0, -0.6E0, 0.8E0, 0.0E0, 00109 + 1.0E0, 0.0E0/ 00110 DATA DATRUE/0.5E0, 0.5E0, 0.5E0, -0.5E0, -0.5E0, 00111 + 0.0E0, 1.0E0, 1.0E0/ 00112 DATA DBTRUE/0.0E0, 0.6E0, 0.0E0, -0.6E0, 0.0E0, 00113 + 0.0E0, 1.0E0, 0.0E0/ 00114 * .. Executable Statements .. 00115 * 00116 * Compute true values which cannot be prestored 00117 * in decimal notation 00118 * 00119 DBTRUE(1) = 1.0E0/0.6E0 00120 DBTRUE(3) = -1.0E0/0.6E0 00121 DBTRUE(5) = 1.0E0/0.6E0 00122 * 00123 DO 20 K = 1, 8 00124 * .. Set N=K for identification in output if any .. 00125 N = K 00126 IF (ICASE.EQ.3) THEN 00127 * .. SROTG .. 00128 IF (K.GT.8) GO TO 40 00129 SA = DA1(K) 00130 SB = DB1(K) 00131 CALL SROTG(SA,SB,SC,SS) 00132 CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC) 00133 CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC) 00134 CALL STEST1(SC,DC1(K),DC1(K),SFAC) 00135 CALL STEST1(SS,DS1(K),DS1(K),SFAC) 00136 ELSE 00137 WRITE (NOUT,*) ' Shouldn''t be here in CHECK0' 00138 STOP 00139 END IF 00140 20 CONTINUE 00141 40 RETURN 00142 END 00143 SUBROUTINE CHECK1(SFAC) 00144 * .. Parameters .. 00145 INTEGER NOUT 00146 PARAMETER (NOUT=6) 00147 * .. Scalar Arguments .. 00148 REAL SFAC 00149 * .. Scalars in Common .. 00150 INTEGER ICASE, INCX, INCY, MODE, N 00151 LOGICAL PASS 00152 * .. Local Scalars .. 00153 INTEGER I, LEN, NP1 00154 * .. Local Arrays .. 00155 REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2), 00156 + SA(10), STEMP(1), STRUE(8), SX(8) 00157 INTEGER ITRUE2(5) 00158 * .. External Functions .. 00159 REAL SASUM, SNRM2 00160 INTEGER ISAMAX 00161 EXTERNAL SASUM, SNRM2, ISAMAX 00162 * .. External Subroutines .. 00163 EXTERNAL ITEST1, SSCAL, STEST, STEST1 00164 * .. Intrinsic Functions .. 00165 INTRINSIC MAX 00166 * .. Common blocks .. 00167 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00168 * .. Data statements .. 00169 DATA SA/0.3E0, -1.0E0, 0.0E0, 1.0E0, 0.3E0, 0.3E0, 00170 + 0.3E0, 0.3E0, 0.3E0, 0.3E0/ 00171 DATA DV/0.1E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 00172 + 2.0E0, 2.0E0, 0.3E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 00173 + 3.0E0, 3.0E0, 3.0E0, 0.3E0, -0.4E0, 4.0E0, 00174 + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 0.2E0, 00175 + -0.6E0, 0.3E0, 5.0E0, 5.0E0, 5.0E0, 5.0E0, 00176 + 5.0E0, 0.1E0, -0.3E0, 0.5E0, -0.1E0, 6.0E0, 00177 + 6.0E0, 6.0E0, 6.0E0, 0.1E0, 8.0E0, 8.0E0, 8.0E0, 00178 + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 0.3E0, 9.0E0, 9.0E0, 00179 + 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 0.3E0, 2.0E0, 00180 + -0.4E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 00181 + 0.2E0, 3.0E0, -0.6E0, 5.0E0, 0.3E0, 2.0E0, 00182 + 2.0E0, 2.0E0, 0.1E0, 4.0E0, -0.3E0, 6.0E0, 00183 + -0.5E0, 7.0E0, -0.1E0, 3.0E0/ 00184 DATA DTRUE1/0.0E0, 0.3E0, 0.5E0, 0.7E0, 0.6E0/ 00185 DATA DTRUE3/0.0E0, 0.3E0, 0.7E0, 1.1E0, 1.0E0/ 00186 DATA DTRUE5/0.10E0, 2.0E0, 2.0E0, 2.0E0, 2.0E0, 00187 + 2.0E0, 2.0E0, 2.0E0, -0.3E0, 3.0E0, 3.0E0, 00188 + 3.0E0, 3.0E0, 3.0E0, 3.0E0, 3.0E0, 0.0E0, 0.0E0, 00189 + 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 4.0E0, 00190 + 0.20E0, -0.60E0, 0.30E0, 5.0E0, 5.0E0, 5.0E0, 00191 + 5.0E0, 5.0E0, 0.03E0, -0.09E0, 0.15E0, -0.03E0, 00192 + 6.0E0, 6.0E0, 6.0E0, 6.0E0, 0.10E0, 8.0E0, 00193 + 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 8.0E0, 00194 + 0.09E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 9.0E0, 00195 + 9.0E0, 9.0E0, 0.09E0, 2.0E0, -0.12E0, 2.0E0, 00196 + 2.0E0, 2.0E0, 2.0E0, 2.0E0, 0.06E0, 3.0E0, 00197 + -0.18E0, 5.0E0, 0.09E0, 2.0E0, 2.0E0, 2.0E0, 00198 + 0.03E0, 4.0E0, -0.09E0, 6.0E0, -0.15E0, 7.0E0, 00199 + -0.03E0, 3.0E0/ 00200 DATA ITRUE2/0, 1, 2, 2, 3/ 00201 * .. Executable Statements .. 00202 DO 80 INCX = 1, 2 00203 DO 60 NP1 = 1, 5 00204 N = NP1 - 1 00205 LEN = 2*MAX(N,1) 00206 * .. Set vector arguments .. 00207 DO 20 I = 1, LEN 00208 SX(I) = DV(I,NP1,INCX) 00209 20 CONTINUE 00210 * 00211 IF (ICASE.EQ.7) THEN 00212 * .. SNRM2 .. 00213 STEMP(1) = DTRUE1(NP1) 00214 CALL STEST1(SNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC) 00215 ELSE IF (ICASE.EQ.8) THEN 00216 * .. SASUM .. 00217 STEMP(1) = DTRUE3(NP1) 00218 CALL STEST1(SASUM(N,SX,INCX),STEMP(1),STEMP,SFAC) 00219 ELSE IF (ICASE.EQ.9) THEN 00220 * .. SSCAL .. 00221 CALL SSCAL(N,SA((INCX-1)*5+NP1),SX,INCX) 00222 DO 40 I = 1, LEN 00223 STRUE(I) = DTRUE5(I,NP1,INCX) 00224 40 CONTINUE 00225 CALL STEST(LEN,SX,STRUE,STRUE,SFAC) 00226 ELSE IF (ICASE.EQ.10) THEN 00227 * .. ISAMAX .. 00228 CALL ITEST1(ISAMAX(N,SX,INCX),ITRUE2(NP1)) 00229 ELSE 00230 WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' 00231 STOP 00232 END IF 00233 60 CONTINUE 00234 80 CONTINUE 00235 RETURN 00236 END 00237 SUBROUTINE CHECK2(SFAC) 00238 * .. Parameters .. 00239 INTEGER NOUT 00240 PARAMETER (NOUT=6) 00241 * .. Scalar Arguments .. 00242 REAL SFAC 00243 * .. Scalars in Common .. 00244 INTEGER ICASE, INCX, INCY, MODE, N 00245 LOGICAL PASS 00246 * .. Local Scalars .. 00247 REAL SA 00248 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY 00249 * .. Local Arrays .. 00250 REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4), 00251 + DT8(7,4,4), DX1(7), 00252 + DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7), 00253 + SX(7), SY(7) 00254 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) 00255 * .. External Functions .. 00256 REAL SDOT 00257 EXTERNAL SDOT 00258 * .. External Subroutines .. 00259 EXTERNAL SAXPY, SCOPY, SSWAP, STEST, STEST1 00260 * .. Intrinsic Functions .. 00261 INTRINSIC ABS, MIN 00262 * .. Common blocks .. 00263 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00264 * .. Data statements .. 00265 DATA SA/0.3E0/ 00266 DATA INCXS/1, 2, -2, -1/ 00267 DATA INCYS/1, -2, 1, -2/ 00268 DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ 00269 DATA NS/0, 1, 2, 4/ 00270 DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, 00271 + -0.4E0/ 00272 DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, 00273 + 0.8E0/ 00274 DATA DT7/0.0E0, 0.30E0, 0.21E0, 0.62E0, 0.0E0, 00275 + 0.30E0, -0.07E0, 0.85E0, 0.0E0, 0.30E0, -0.79E0, 00276 + -0.74E0, 0.0E0, 0.30E0, 0.33E0, 1.27E0/ 00277 DATA DT8/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00278 + 0.0E0, 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00279 + 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.0E0, 0.0E0, 00280 + 0.0E0, 0.0E0, 0.0E0, 0.68E0, -0.87E0, 0.15E0, 00281 + 0.94E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 00282 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.68E0, 00283 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00284 + 0.35E0, -0.9E0, 0.48E0, 0.0E0, 0.0E0, 0.0E0, 00285 + 0.0E0, 0.38E0, -0.9E0, 0.57E0, 0.7E0, -0.75E0, 00286 + 0.2E0, 0.98E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 00287 + 0.0E0, 0.0E0, 0.0E0, 0.68E0, 0.0E0, 0.0E0, 00288 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.35E0, -0.72E0, 00289 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.38E0, 00290 + -0.63E0, 0.15E0, 0.88E0, 0.0E0, 0.0E0, 0.0E0, 00291 + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00292 + 0.68E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00293 + 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.0E0, 0.0E0, 00294 + 0.0E0, 0.0E0, 0.68E0, -0.9E0, 0.33E0, 0.7E0, 00295 + -0.75E0, 0.2E0, 1.04E0/ 00296 DATA DT10X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00297 + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00298 + 0.0E0, 0.5E0, -0.9E0, 0.0E0, 0.0E0, 0.0E0, 00299 + 0.0E0, 0.0E0, 0.5E0, -0.9E0, 0.3E0, 0.7E0, 00300 + 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 00301 + 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 00302 + 0.0E0, 0.0E0, 0.0E0, 0.3E0, 0.1E0, 0.5E0, 0.0E0, 00303 + 0.0E0, 0.0E0, 0.0E0, 0.8E0, 0.1E0, -0.6E0, 00304 + 0.8E0, 0.3E0, -0.3E0, 0.5E0, 0.6E0, 0.0E0, 00305 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 00306 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.9E0, 00307 + 0.1E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, 00308 + 0.1E0, 0.3E0, 0.8E0, -0.9E0, -0.3E0, 0.5E0, 00309 + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00310 + 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00311 + 0.5E0, 0.3E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00312 + 0.5E0, 0.3E0, -0.6E0, 0.8E0, 0.0E0, 0.0E0, 00313 + 0.0E0/ 00314 DATA DT10Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00315 + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00316 + 0.0E0, 0.6E0, 0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00317 + 0.0E0, 0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.0E0, 00318 + 0.0E0, 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00319 + 0.0E0, 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00320 + 0.0E0, 0.0E0, -0.5E0, -0.9E0, 0.6E0, 0.0E0, 00321 + 0.0E0, 0.0E0, 0.0E0, -0.4E0, -0.9E0, 0.9E0, 00322 + 0.7E0, -0.5E0, 0.2E0, 0.6E0, 0.5E0, 0.0E0, 00323 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 00324 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.5E0, 00325 + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00326 + -0.4E0, 0.9E0, -0.5E0, 0.6E0, 0.0E0, 0.0E0, 00327 + 0.0E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00328 + 0.0E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00329 + 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.0E0, 0.0E0, 00330 + 0.0E0, 0.0E0, 0.6E0, -0.9E0, 0.1E0, 0.7E0, 00331 + -0.5E0, 0.2E0, 0.8E0/ 00332 DATA SSIZE1/0.0E0, 0.3E0, 1.6E0, 3.2E0/ 00333 DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00334 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00335 + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 00336 + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 00337 + 1.17E0, 1.17E0, 1.17E0/ 00338 * .. Executable Statements .. 00339 * 00340 DO 120 KI = 1, 4 00341 INCX = INCXS(KI) 00342 INCY = INCYS(KI) 00343 MX = ABS(INCX) 00344 MY = ABS(INCY) 00345 * 00346 DO 100 KN = 1, 4 00347 N = NS(KN) 00348 KSIZE = MIN(2,KN) 00349 LENX = LENS(KN,MX) 00350 LENY = LENS(KN,MY) 00351 * .. Initialize all argument arrays .. 00352 DO 20 I = 1, 7 00353 SX(I) = DX1(I) 00354 SY(I) = DY1(I) 00355 20 CONTINUE 00356 * 00357 IF (ICASE.EQ.1) THEN 00358 * .. SDOT .. 00359 CALL STEST1(SDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN) 00360 + ,SFAC) 00361 ELSE IF (ICASE.EQ.2) THEN 00362 * .. SAXPY .. 00363 CALL SAXPY(N,SA,SX,INCX,SY,INCY) 00364 DO 40 J = 1, LENY 00365 STY(J) = DT8(J,KN,KI) 00366 40 CONTINUE 00367 CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) 00368 ELSE IF (ICASE.EQ.5) THEN 00369 * .. SCOPY .. 00370 DO 60 I = 1, 7 00371 STY(I) = DT10Y(I,KN,KI) 00372 60 CONTINUE 00373 CALL SCOPY(N,SX,INCX,SY,INCY) 00374 CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) 00375 ELSE IF (ICASE.EQ.6) THEN 00376 * .. SSWAP .. 00377 CALL SSWAP(N,SX,INCX,SY,INCY) 00378 DO 80 I = 1, 7 00379 STX(I) = DT10X(I,KN,KI) 00380 STY(I) = DT10Y(I,KN,KI) 00381 80 CONTINUE 00382 CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0E0) 00383 CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0E0) 00384 ELSE 00385 WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' 00386 STOP 00387 END IF 00388 100 CONTINUE 00389 120 CONTINUE 00390 RETURN 00391 END 00392 SUBROUTINE CHECK3(SFAC) 00393 * .. Parameters .. 00394 INTEGER NOUT 00395 PARAMETER (NOUT=6) 00396 * .. Scalar Arguments .. 00397 REAL SFAC 00398 * .. Scalars in Common .. 00399 INTEGER ICASE, INCX, INCY, MODE, N 00400 LOGICAL PASS 00401 * .. Local Scalars .. 00402 REAL SC, SS 00403 INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY 00404 * .. Local Arrays .. 00405 REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4), 00406 + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5), 00407 + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5), 00408 + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7), 00409 + SY(7) 00410 INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11), 00411 + MWPINY(11), MWPN(11), NS(4) 00412 * .. External Subroutines .. 00413 EXTERNAL SROT, STEST 00414 * .. Intrinsic Functions .. 00415 INTRINSIC ABS, MIN 00416 * .. Common blocks .. 00417 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00418 * .. Data statements .. 00419 DATA INCXS/1, 2, -2, -1/ 00420 DATA INCYS/1, -2, 1, -2/ 00421 DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ 00422 DATA NS/0, 1, 2, 4/ 00423 DATA DX1/0.6E0, 0.1E0, -0.5E0, 0.8E0, 0.9E0, -0.3E0, 00424 + -0.4E0/ 00425 DATA DY1/0.5E0, -0.9E0, 0.3E0, 0.7E0, -0.6E0, 0.2E0, 00426 + 0.8E0/ 00427 DATA SC, SS/0.8E0, 0.6E0/ 00428 DATA DT9X/0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00429 + 0.0E0, 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00430 + 0.0E0, 0.0E0, 0.78E0, -0.46E0, 0.0E0, 0.0E0, 00431 + 0.0E0, 0.0E0, 0.0E0, 0.78E0, -0.46E0, -0.22E0, 00432 + 1.06E0, 0.0E0, 0.0E0, 0.0E0, 0.6E0, 0.0E0, 00433 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.78E0, 00434 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00435 + 0.66E0, 0.1E0, -0.1E0, 0.0E0, 0.0E0, 0.0E0, 00436 + 0.0E0, 0.96E0, 0.1E0, -0.76E0, 0.8E0, 0.90E0, 00437 + -0.3E0, -0.02E0, 0.6E0, 0.0E0, 0.0E0, 0.0E0, 00438 + 0.0E0, 0.0E0, 0.0E0, 0.78E0, 0.0E0, 0.0E0, 00439 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, -0.06E0, 0.1E0, 00440 + -0.1E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.90E0, 00441 + 0.1E0, -0.22E0, 0.8E0, 0.18E0, -0.3E0, -0.02E0, 00442 + 0.6E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00443 + 0.78E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00444 + 0.0E0, 0.78E0, 0.26E0, 0.0E0, 0.0E0, 0.0E0, 00445 + 0.0E0, 0.0E0, 0.78E0, 0.26E0, -0.76E0, 1.12E0, 00446 + 0.0E0, 0.0E0, 0.0E0/ 00447 DATA DT9Y/0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00448 + 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00449 + 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.0E0, 0.0E0, 00450 + 0.0E0, 0.0E0, 0.0E0, 0.04E0, -0.78E0, 0.54E0, 00451 + 0.08E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 0.0E0, 00452 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.04E0, 00453 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.7E0, 00454 + -0.9E0, -0.12E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00455 + 0.64E0, -0.9E0, -0.30E0, 0.7E0, -0.18E0, 0.2E0, 00456 + 0.28E0, 0.5E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00457 + 0.0E0, 0.0E0, 0.04E0, 0.0E0, 0.0E0, 0.0E0, 00458 + 0.0E0, 0.0E0, 0.0E0, 0.7E0, -1.08E0, 0.0E0, 00459 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.64E0, -1.26E0, 00460 + 0.54E0, 0.20E0, 0.0E0, 0.0E0, 0.0E0, 0.5E0, 00461 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00462 + 0.04E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00463 + 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.0E0, 0.0E0, 00464 + 0.0E0, 0.0E0, 0.04E0, -0.9E0, 0.18E0, 0.7E0, 00465 + -0.18E0, 0.2E0, 0.16E0/ 00466 DATA SSIZE2/0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00467 + 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 0.0E0, 00468 + 0.0E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 00469 + 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 1.17E0, 00470 + 1.17E0, 1.17E0, 1.17E0/ 00471 * .. Executable Statements .. 00472 * 00473 DO 60 KI = 1, 4 00474 INCX = INCXS(KI) 00475 INCY = INCYS(KI) 00476 MX = ABS(INCX) 00477 MY = ABS(INCY) 00478 * 00479 DO 40 KN = 1, 4 00480 N = NS(KN) 00481 KSIZE = MIN(2,KN) 00482 LENX = LENS(KN,MX) 00483 LENY = LENS(KN,MY) 00484 * 00485 IF (ICASE.EQ.4) THEN 00486 * .. SROT .. 00487 DO 20 I = 1, 7 00488 SX(I) = DX1(I) 00489 SY(I) = DY1(I) 00490 STX(I) = DT9X(I,KN,KI) 00491 STY(I) = DT9Y(I,KN,KI) 00492 20 CONTINUE 00493 CALL SROT(N,SX,INCX,SY,INCY,SC,SS) 00494 CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC) 00495 CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC) 00496 ELSE 00497 WRITE (NOUT,*) ' Shouldn''t be here in CHECK3' 00498 STOP 00499 END IF 00500 40 CONTINUE 00501 60 CONTINUE 00502 * 00503 MWPC(1) = 1 00504 DO 80 I = 2, 11 00505 MWPC(I) = 0 00506 80 CONTINUE 00507 MWPS(1) = 0 00508 DO 100 I = 2, 6 00509 MWPS(I) = 1 00510 100 CONTINUE 00511 DO 120 I = 7, 11 00512 MWPS(I) = -1 00513 120 CONTINUE 00514 MWPINX(1) = 1 00515 MWPINX(2) = 1 00516 MWPINX(3) = 1 00517 MWPINX(4) = -1 00518 MWPINX(5) = 1 00519 MWPINX(6) = -1 00520 MWPINX(7) = 1 00521 MWPINX(8) = 1 00522 MWPINX(9) = -1 00523 MWPINX(10) = 1 00524 MWPINX(11) = -1 00525 MWPINY(1) = 1 00526 MWPINY(2) = 1 00527 MWPINY(3) = -1 00528 MWPINY(4) = -1 00529 MWPINY(5) = 2 00530 MWPINY(6) = 1 00531 MWPINY(7) = 1 00532 MWPINY(8) = -1 00533 MWPINY(9) = -1 00534 MWPINY(10) = 2 00535 MWPINY(11) = 1 00536 DO 140 I = 1, 11 00537 MWPN(I) = 5 00538 140 CONTINUE 00539 MWPN(5) = 3 00540 MWPN(10) = 3 00541 DO 160 I = 1, 5 00542 MWPX(I) = I 00543 MWPY(I) = I 00544 MWPTX(1,I) = I 00545 MWPTY(1,I) = I 00546 MWPTX(2,I) = I 00547 MWPTY(2,I) = -I 00548 MWPTX(3,I) = 6 - I 00549 MWPTY(3,I) = I - 6 00550 MWPTX(4,I) = I 00551 MWPTY(4,I) = -I 00552 MWPTX(6,I) = 6 - I 00553 MWPTY(6,I) = I - 6 00554 MWPTX(7,I) = -I 00555 MWPTY(7,I) = I 00556 MWPTX(8,I) = I - 6 00557 MWPTY(8,I) = 6 - I 00558 MWPTX(9,I) = -I 00559 MWPTY(9,I) = I 00560 MWPTX(11,I) = I - 6 00561 MWPTY(11,I) = 6 - I 00562 160 CONTINUE 00563 MWPTX(5,1) = 1 00564 MWPTX(5,2) = 3 00565 MWPTX(5,3) = 5 00566 MWPTX(5,4) = 4 00567 MWPTX(5,5) = 5 00568 MWPTY(5,1) = -1 00569 MWPTY(5,2) = 2 00570 MWPTY(5,3) = -2 00571 MWPTY(5,4) = 4 00572 MWPTY(5,5) = -3 00573 MWPTX(10,1) = -1 00574 MWPTX(10,2) = -3 00575 MWPTX(10,3) = -5 00576 MWPTX(10,4) = 4 00577 MWPTX(10,5) = 5 00578 MWPTY(10,1) = 1 00579 MWPTY(10,2) = 2 00580 MWPTY(10,3) = 2 00581 MWPTY(10,4) = 4 00582 MWPTY(10,5) = 3 00583 DO 200 I = 1, 11 00584 INCX = MWPINX(I) 00585 INCY = MWPINY(I) 00586 DO 180 K = 1, 5 00587 COPYX(K) = MWPX(K) 00588 COPYY(K) = MWPY(K) 00589 MWPSTX(K) = MWPTX(I,K) 00590 MWPSTY(K) = MWPTY(I,K) 00591 180 CONTINUE 00592 CALL SROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I)) 00593 CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC) 00594 CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC) 00595 200 CONTINUE 00596 RETURN 00597 END 00598 SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) 00599 * ********************************* STEST ************************** 00600 * 00601 * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO 00602 * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE 00603 * NEGLIGIBLE. 00604 * 00605 * C. L. LAWSON, JPL, 1974 DEC 10 00606 * 00607 * .. Parameters .. 00608 INTEGER NOUT 00609 PARAMETER (NOUT=6) 00610 * .. Scalar Arguments .. 00611 REAL SFAC 00612 INTEGER LEN 00613 * .. Array Arguments .. 00614 REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) 00615 * .. Scalars in Common .. 00616 INTEGER ICASE, INCX, INCY, MODE, N 00617 LOGICAL PASS 00618 * .. Local Scalars .. 00619 REAL SD 00620 INTEGER I 00621 * .. External Functions .. 00622 REAL SDIFF 00623 EXTERNAL SDIFF 00624 * .. Intrinsic Functions .. 00625 INTRINSIC ABS 00626 * .. Common blocks .. 00627 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00628 * .. Executable Statements .. 00629 * 00630 DO 40 I = 1, LEN 00631 SD = SCOMP(I) - STRUE(I) 00632 IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0E0) 00633 + GO TO 40 00634 * 00635 * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). 00636 * 00637 IF ( .NOT. PASS) GO TO 20 00638 * PRINT FAIL MESSAGE AND HEADER. 00639 PASS = .FALSE. 00640 WRITE (NOUT,99999) 00641 WRITE (NOUT,99998) 00642 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), 00643 + STRUE(I), SD, SSIZE(I) 00644 40 CONTINUE 00645 RETURN 00646 * 00647 99999 FORMAT (' FAIL') 00648 99998 FORMAT (/' CASE N INCX INCY MODE I ', 00649 + ' COMP(I) TRUE(I) DIFFERENCE', 00650 + ' SIZE(I)',/1X) 00651 99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4) 00652 END 00653 SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) 00654 * ************************* STEST1 ***************************** 00655 * 00656 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN 00657 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE 00658 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. 00659 * 00660 * C.L. LAWSON, JPL, 1978 DEC 6 00661 * 00662 * .. Scalar Arguments .. 00663 REAL SCOMP1, SFAC, STRUE1 00664 * .. Array Arguments .. 00665 REAL SSIZE(*) 00666 * .. Local Arrays .. 00667 REAL SCOMP(1), STRUE(1) 00668 * .. External Subroutines .. 00669 EXTERNAL STEST 00670 * .. Executable Statements .. 00671 * 00672 SCOMP(1) = SCOMP1 00673 STRUE(1) = STRUE1 00674 CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) 00675 * 00676 RETURN 00677 END 00678 REAL FUNCTION SDIFF(SA,SB) 00679 * ********************************* SDIFF ************************** 00680 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 00681 * 00682 * .. Scalar Arguments .. 00683 REAL SA, SB 00684 * .. Executable Statements .. 00685 SDIFF = SA - SB 00686 RETURN 00687 END 00688 SUBROUTINE ITEST1(ICOMP,ITRUE) 00689 * ********************************* ITEST1 ************************* 00690 * 00691 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR 00692 * EQUALITY. 00693 * C. L. LAWSON, JPL, 1974 DEC 10 00694 * 00695 * .. Parameters .. 00696 INTEGER NOUT 00697 PARAMETER (NOUT=6) 00698 * .. Scalar Arguments .. 00699 INTEGER ICOMP, ITRUE 00700 * .. Scalars in Common .. 00701 INTEGER ICASE, INCX, INCY, MODE, N 00702 LOGICAL PASS 00703 * .. Local Scalars .. 00704 INTEGER ID 00705 * .. Common blocks .. 00706 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00707 * .. Executable Statements .. 00708 * 00709 IF (ICOMP.EQ.ITRUE) GO TO 40 00710 * 00711 * HERE ICOMP IS NOT EQUAL TO ITRUE. 00712 * 00713 IF ( .NOT. PASS) GO TO 20 00714 * PRINT FAIL MESSAGE AND HEADER. 00715 PASS = .FALSE. 00716 WRITE (NOUT,99999) 00717 WRITE (NOUT,99998) 00718 20 ID = ICOMP - ITRUE 00719 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID 00720 40 CONTINUE 00721 RETURN 00722 * 00723 99999 FORMAT (' FAIL') 00724 99998 FORMAT (/' CASE N INCX INCY MODE ', 00725 + ' COMP TRUE DIFFERENCE', 00726 + /1X) 00727 99997 FORMAT (1X,I4,I3,3I5,2I36,I12) 00728 END
1.7.3 
