 |
LAPACK 3.3.1
Linear Algebra PACKage
|
|
LAPACK 3.3.1
Linear Algebra PACKage
|
00001 PROGRAM CBLAT1 00002 * Test program for the COMPLEX Level 1 BLAS. 00003 * Based upon the original BLAS test routine together with: 00004 * F06GAF 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 CHECK1, CHECK2, 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.LE.5) THEN 00036 CALL CHECK2(SFAC) 00037 ELSE IF (ICASE.GE.6) THEN 00038 CALL CHECK1(SFAC) 00039 END IF 00040 * -- Print 00041 IF (PASS) WRITE (NOUT,99998) 00042 20 CONTINUE 00043 STOP 00044 * 00045 99999 FORMAT (' Complex BLAS Test Program Results',/1X) 00046 99998 FORMAT (' ----- PASS -----') 00047 END 00048 SUBROUTINE HEADER 00049 * .. Parameters .. 00050 INTEGER NOUT 00051 PARAMETER (NOUT=6) 00052 * .. Scalars in Common .. 00053 INTEGER ICASE, INCX, INCY, MODE, N 00054 LOGICAL PASS 00055 * .. Local Arrays .. 00056 CHARACTER*6 L(10) 00057 * .. Common blocks .. 00058 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00059 * .. Data statements .. 00060 DATA L(1)/'CDOTC '/ 00061 DATA L(2)/'CDOTU '/ 00062 DATA L(3)/'CAXPY '/ 00063 DATA L(4)/'CCOPY '/ 00064 DATA L(5)/'CSWAP '/ 00065 DATA L(6)/'SCNRM2'/ 00066 DATA L(7)/'SCASUM'/ 00067 DATA L(8)/'CSCAL '/ 00068 DATA L(9)/'CSSCAL'/ 00069 DATA L(10)/'ICAMAX'/ 00070 * .. Executable Statements .. 00071 WRITE (NOUT,99999) ICASE, L(ICASE) 00072 RETURN 00073 * 00074 99999 FORMAT (/' Test of subprogram number',I3,12X,A6) 00075 END 00076 SUBROUTINE CHECK1(SFAC) 00077 * .. Parameters .. 00078 INTEGER NOUT 00079 PARAMETER (NOUT=6) 00080 * .. Scalar Arguments .. 00081 REAL SFAC 00082 * .. Scalars in Common .. 00083 INTEGER ICASE, INCX, INCY, MODE, N 00084 LOGICAL PASS 00085 * .. Local Scalars .. 00086 COMPLEX CA 00087 REAL SA 00088 INTEGER I, J, LEN, NP1 00089 * .. Local Arrays .. 00090 COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), 00091 + MWPCS(5), MWPCT(5) 00092 REAL STRUE2(5), STRUE4(5) 00093 INTEGER ITRUE3(5) 00094 * .. External Functions .. 00095 REAL SCASUM, SCNRM2 00096 INTEGER ICAMAX 00097 EXTERNAL SCASUM, SCNRM2, ICAMAX 00098 * .. External Subroutines .. 00099 EXTERNAL CSCAL, CSSCAL, CTEST, ITEST1, STEST1 00100 * .. Intrinsic Functions .. 00101 INTRINSIC MAX 00102 * .. Common blocks .. 00103 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00104 * .. Data statements .. 00105 DATA SA, CA/0.3E0, (0.4E0,-0.7E0)/ 00106 DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 00107 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 00108 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 00109 + (1.0E0,2.0E0), (0.3E0,-0.4E0), (3.0E0,4.0E0), 00110 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 00111 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 00112 + (0.1E0,-0.3E0), (0.5E0,-0.1E0), (5.0E0,6.0E0), 00113 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 00114 + (5.0E0,6.0E0), (5.0E0,6.0E0), (0.1E0,0.1E0), 00115 + (-0.6E0,0.1E0), (0.1E0,-0.3E0), (7.0E0,8.0E0), 00116 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 00117 + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.5E0,0.0E0), 00118 + (0.0E0,0.5E0), (0.0E0,0.2E0), (2.0E0,3.0E0), 00119 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ 00120 DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 00121 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 00122 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 00123 + (4.0E0,5.0E0), (0.3E0,-0.4E0), (6.0E0,7.0E0), 00124 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 00125 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 00126 + (0.1E0,-0.3E0), (8.0E0,9.0E0), (0.5E0,-0.1E0), 00127 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 00128 + (2.0E0,5.0E0), (2.0E0,5.0E0), (0.1E0,0.1E0), 00129 + (3.0E0,6.0E0), (-0.6E0,0.1E0), (4.0E0,7.0E0), 00130 + (0.1E0,-0.3E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 00131 + (7.0E0,2.0E0), (0.3E0,0.1E0), (5.0E0,8.0E0), 00132 + (0.5E0,0.0E0), (6.0E0,9.0E0), (0.0E0,0.5E0), 00133 + (8.0E0,3.0E0), (0.0E0,0.2E0), (9.0E0,4.0E0)/ 00134 DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.8E0/ 00135 DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.6E0/ 00136 DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 00137 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 00138 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 00139 + (1.0E0,2.0E0), (-0.16E0,-0.37E0), (3.0E0,4.0E0), 00140 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 00141 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 00142 + (-0.17E0,-0.19E0), (0.13E0,-0.39E0), 00143 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 00144 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 00145 + (0.11E0,-0.03E0), (-0.17E0,0.46E0), 00146 + (-0.17E0,-0.19E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 00147 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 00148 + (0.19E0,-0.17E0), (0.20E0,-0.35E0), 00149 + (0.35E0,0.20E0), (0.14E0,0.08E0), 00150 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0), 00151 + (2.0E0,3.0E0)/ 00152 DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 00153 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 00154 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 00155 + (4.0E0,5.0E0), (-0.16E0,-0.37E0), (6.0E0,7.0E0), 00156 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 00157 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 00158 + (-0.17E0,-0.19E0), (8.0E0,9.0E0), 00159 + (0.13E0,-0.39E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 00160 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 00161 + (0.11E0,-0.03E0), (3.0E0,6.0E0), 00162 + (-0.17E0,0.46E0), (4.0E0,7.0E0), 00163 + (-0.17E0,-0.19E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 00164 + (7.0E0,2.0E0), (0.19E0,-0.17E0), (5.0E0,8.0E0), 00165 + (0.20E0,-0.35E0), (6.0E0,9.0E0), 00166 + (0.35E0,0.20E0), (8.0E0,3.0E0), 00167 + (0.14E0,0.08E0), (9.0E0,4.0E0)/ 00168 DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 00169 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 00170 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 00171 + (1.0E0,2.0E0), (0.09E0,-0.12E0), (3.0E0,4.0E0), 00172 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 00173 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 00174 + (0.03E0,-0.09E0), (0.15E0,-0.03E0), 00175 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 00176 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 00177 + (0.03E0,0.03E0), (-0.18E0,0.03E0), 00178 + (0.03E0,-0.09E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 00179 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 00180 + (0.09E0,0.03E0), (0.15E0,0.00E0), 00181 + (0.00E0,0.15E0), (0.00E0,0.06E0), (2.0E0,3.0E0), 00182 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ 00183 DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 00184 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 00185 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 00186 + (4.0E0,5.0E0), (0.09E0,-0.12E0), (6.0E0,7.0E0), 00187 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 00188 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 00189 + (0.03E0,-0.09E0), (8.0E0,9.0E0), 00190 + (0.15E0,-0.03E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 00191 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 00192 + (0.03E0,0.03E0), (3.0E0,6.0E0), 00193 + (-0.18E0,0.03E0), (4.0E0,7.0E0), 00194 + (0.03E0,-0.09E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 00195 + (7.0E0,2.0E0), (0.09E0,0.03E0), (5.0E0,8.0E0), 00196 + (0.15E0,0.00E0), (6.0E0,9.0E0), (0.00E0,0.15E0), 00197 + (8.0E0,3.0E0), (0.00E0,0.06E0), (9.0E0,4.0E0)/ 00198 DATA ITRUE3/0, 1, 2, 2, 2/ 00199 * .. Executable Statements .. 00200 DO 60 INCX = 1, 2 00201 DO 40 NP1 = 1, 5 00202 N = NP1 - 1 00203 LEN = 2*MAX(N,1) 00204 * .. Set vector arguments .. 00205 DO 20 I = 1, LEN 00206 CX(I) = CV(I,NP1,INCX) 00207 20 CONTINUE 00208 IF (ICASE.EQ.6) THEN 00209 * .. SCNRM2 .. 00210 CALL STEST1(SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1), 00211 + SFAC) 00212 ELSE IF (ICASE.EQ.7) THEN 00213 * .. SCASUM .. 00214 CALL STEST1(SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1), 00215 + SFAC) 00216 ELSE IF (ICASE.EQ.8) THEN 00217 * .. CSCAL .. 00218 CALL CSCAL(N,CA,CX,INCX) 00219 CALL CTEST(LEN,CX,CTRUE5(1,NP1,INCX),CTRUE5(1,NP1,INCX), 00220 + SFAC) 00221 ELSE IF (ICASE.EQ.9) THEN 00222 * .. CSSCAL .. 00223 CALL CSSCAL(N,SA,CX,INCX) 00224 CALL CTEST(LEN,CX,CTRUE6(1,NP1,INCX),CTRUE6(1,NP1,INCX), 00225 + SFAC) 00226 ELSE IF (ICASE.EQ.10) THEN 00227 * .. ICAMAX .. 00228 CALL ITEST1(ICAMAX(N,CX,INCX),ITRUE3(NP1)) 00229 ELSE 00230 WRITE (NOUT,*) ' Shouldn''t be here in CHECK1' 00231 STOP 00232 END IF 00233 * 00234 40 CONTINUE 00235 60 CONTINUE 00236 * 00237 INCX = 1 00238 IF (ICASE.EQ.8) THEN 00239 * CSCAL 00240 * Add a test for alpha equal to zero. 00241 CA = (0.0E0,0.0E0) 00242 DO 80 I = 1, 5 00243 MWPCT(I) = (0.0E0,0.0E0) 00244 MWPCS(I) = (1.0E0,1.0E0) 00245 80 CONTINUE 00246 CALL CSCAL(5,CA,CX,INCX) 00247 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 00248 ELSE IF (ICASE.EQ.9) THEN 00249 * CSSCAL 00250 * Add a test for alpha equal to zero. 00251 SA = 0.0E0 00252 DO 100 I = 1, 5 00253 MWPCT(I) = (0.0E0,0.0E0) 00254 MWPCS(I) = (1.0E0,1.0E0) 00255 100 CONTINUE 00256 CALL CSSCAL(5,SA,CX,INCX) 00257 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 00258 * Add a test for alpha equal to one. 00259 SA = 1.0E0 00260 DO 120 I = 1, 5 00261 MWPCT(I) = CX(I) 00262 MWPCS(I) = CX(I) 00263 120 CONTINUE 00264 CALL CSSCAL(5,SA,CX,INCX) 00265 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 00266 * Add a test for alpha equal to minus one. 00267 SA = -1.0E0 00268 DO 140 I = 1, 5 00269 MWPCT(I) = -CX(I) 00270 MWPCS(I) = -CX(I) 00271 140 CONTINUE 00272 CALL CSSCAL(5,SA,CX,INCX) 00273 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 00274 END IF 00275 RETURN 00276 END 00277 SUBROUTINE CHECK2(SFAC) 00278 * .. Parameters .. 00279 INTEGER NOUT 00280 PARAMETER (NOUT=6) 00281 * .. Scalar Arguments .. 00282 REAL SFAC 00283 * .. Scalars in Common .. 00284 INTEGER ICASE, INCX, INCY, MODE, N 00285 LOGICAL PASS 00286 * .. Local Scalars .. 00287 COMPLEX CA 00288 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY 00289 * .. Local Arrays .. 00290 COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14), 00291 + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4), 00292 + CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7) 00293 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4) 00294 * .. External Functions .. 00295 COMPLEX CDOTC, CDOTU 00296 EXTERNAL CDOTC, CDOTU 00297 * .. External Subroutines .. 00298 EXTERNAL CAXPY, CCOPY, CSWAP, CTEST 00299 * .. Intrinsic Functions .. 00300 INTRINSIC ABS, MIN 00301 * .. Common blocks .. 00302 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00303 * .. Data statements .. 00304 DATA CA/(0.4E0,-0.7E0)/ 00305 DATA INCXS/1, 2, -2, -1/ 00306 DATA INCYS/1, -2, 1, -2/ 00307 DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/ 00308 DATA NS/0, 1, 2, 4/ 00309 DATA CX1/(0.7E0,-0.8E0), (-0.4E0,-0.7E0), 00310 + (-0.1E0,-0.9E0), (0.2E0,-0.8E0), 00311 + (-0.9E0,-0.4E0), (0.1E0,0.4E0), (-0.6E0,0.6E0)/ 00312 DATA CY1/(0.6E0,-0.6E0), (-0.9E0,0.5E0), 00313 + (0.7E0,-0.6E0), (0.1E0,-0.5E0), (-0.1E0,-0.2E0), 00314 + (-0.5E0,-0.3E0), (0.8E0,-0.7E0)/ 00315 DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), 00316 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00317 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00318 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00319 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00320 + (0.0E0,0.0E0), (0.32E0,-1.41E0), 00321 + (-1.55E0,0.5E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00322 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00323 + (0.32E0,-1.41E0), (-1.55E0,0.5E0), 00324 + (0.03E0,-0.89E0), (-0.38E0,-0.96E0), 00325 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 00326 DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), 00327 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00328 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00329 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00330 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00331 + (0.0E0,0.0E0), (-0.07E0,-0.89E0), 00332 + (-0.9E0,0.5E0), (0.42E0,-1.41E0), (0.0E0,0.0E0), 00333 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00334 + (0.78E0,0.06E0), (-0.9E0,0.5E0), 00335 + (0.06E0,-0.13E0), (0.1E0,-0.5E0), 00336 + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), 00337 + (0.52E0,-1.51E0)/ 00338 DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), 00339 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00340 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00341 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00342 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00343 + (0.0E0,0.0E0), (-0.07E0,-0.89E0), 00344 + (-1.18E0,-0.31E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00345 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00346 + (0.78E0,0.06E0), (-1.54E0,0.97E0), 00347 + (0.03E0,-0.89E0), (-0.18E0,-1.31E0), 00348 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 00349 DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), 00350 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00351 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00352 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00353 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00354 + (0.0E0,0.0E0), (0.32E0,-1.41E0), (-0.9E0,0.5E0), 00355 + (0.05E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00356 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.32E0,-1.41E0), 00357 + (-0.9E0,0.5E0), (0.05E0,-0.6E0), (0.1E0,-0.5E0), 00358 + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), 00359 + (0.32E0,-1.16E0)/ 00360 DATA CT7/(0.0E0,0.0E0), (-0.06E0,-0.90E0), 00361 + (0.65E0,-0.47E0), (-0.34E0,-1.22E0), 00362 + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 00363 + (-0.59E0,-1.46E0), (-1.04E0,-0.04E0), 00364 + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 00365 + (-0.83E0,0.59E0), (0.07E0,-0.37E0), 00366 + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 00367 + (-0.76E0,-1.15E0), (-1.33E0,-1.82E0)/ 00368 DATA CT6/(0.0E0,0.0E0), (0.90E0,0.06E0), 00369 + (0.91E0,-0.77E0), (1.80E0,-0.10E0), 00370 + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.45E0,0.74E0), 00371 + (0.20E0,0.90E0), (0.0E0,0.0E0), (0.90E0,0.06E0), 00372 + (-0.55E0,0.23E0), (0.83E0,-0.39E0), 00373 + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.04E0,0.79E0), 00374 + (1.95E0,1.22E0)/ 00375 DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7E0,-0.8E0), 00376 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00377 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00378 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00379 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00380 + (0.0E0,0.0E0), (0.6E0,-0.6E0), (-0.9E0,0.5E0), 00381 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00382 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), 00383 + (-0.9E0,0.5E0), (0.7E0,-0.6E0), (0.1E0,-0.5E0), 00384 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 00385 DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7E0,-0.8E0), 00386 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00387 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00388 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00389 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00390 + (0.0E0,0.0E0), (0.7E0,-0.6E0), (-0.4E0,-0.7E0), 00391 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00392 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.8E0,-0.7E0), 00393 + (-0.4E0,-0.7E0), (-0.1E0,-0.2E0), 00394 + (0.2E0,-0.8E0), (0.7E0,-0.6E0), (0.1E0,0.4E0), 00395 + (0.6E0,-0.6E0)/ 00396 DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7E0,-0.8E0), 00397 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00398 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00399 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00400 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00401 + (0.0E0,0.0E0), (-0.9E0,0.5E0), (-0.4E0,-0.7E0), 00402 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00403 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.1E0,-0.5E0), 00404 + (-0.4E0,-0.7E0), (0.7E0,-0.6E0), (0.2E0,-0.8E0), 00405 + (-0.9E0,0.5E0), (0.1E0,0.4E0), (0.6E0,-0.6E0)/ 00406 DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7E0,-0.8E0), 00407 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00408 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00409 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00410 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00411 + (0.0E0,0.0E0), (0.6E0,-0.6E0), (0.7E0,-0.6E0), 00412 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00413 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), 00414 + (0.7E0,-0.6E0), (-0.1E0,-0.2E0), (0.8E0,-0.7E0), 00415 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 00416 DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), 00417 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00418 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00419 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00420 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00421 + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.4E0,-0.7E0), 00422 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00423 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), 00424 + (-0.4E0,-0.7E0), (-0.1E0,-0.9E0), 00425 + (0.2E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00426 + (0.0E0,0.0E0)/ 00427 DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), 00428 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00429 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00430 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00431 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00432 + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (-0.9E0,0.5E0), 00433 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00434 + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), 00435 + (-0.9E0,0.5E0), (-0.9E0,-0.4E0), (0.1E0,-0.5E0), 00436 + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), 00437 + (0.7E0,-0.8E0)/ 00438 DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), 00439 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00440 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00441 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00442 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00443 + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (0.7E0,-0.8E0), 00444 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00445 + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), 00446 + (-0.9E0,-0.4E0), (-0.1E0,-0.9E0), 00447 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00448 + (0.0E0,0.0E0)/ 00449 DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), 00450 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00451 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00452 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00453 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00454 + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.9E0,0.5E0), 00455 + (-0.4E0,-0.7E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00456 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), 00457 + (-0.9E0,0.5E0), (-0.4E0,-0.7E0), (0.1E0,-0.5E0), 00458 + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), 00459 + (0.2E0,-0.8E0)/ 00460 DATA CSIZE1/(0.0E0,0.0E0), (0.9E0,0.9E0), 00461 + (1.63E0,1.73E0), (2.90E0,2.78E0)/ 00462 DATA CSIZE3/(0.0E0,0.0E0), (0.0E0,0.0E0), 00463 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00464 + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.17E0,1.17E0), 00465 + (1.17E0,1.17E0), (1.17E0,1.17E0), 00466 + (1.17E0,1.17E0), (1.17E0,1.17E0), 00467 + (1.17E0,1.17E0), (1.17E0,1.17E0)/ 00468 DATA CSIZE2/(0.0E0,0.0E0), (0.0E0,0.0E0), 00469 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 00470 + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.54E0,1.54E0), 00471 + (1.54E0,1.54E0), (1.54E0,1.54E0), 00472 + (1.54E0,1.54E0), (1.54E0,1.54E0), 00473 + (1.54E0,1.54E0), (1.54E0,1.54E0)/ 00474 * .. Executable Statements .. 00475 DO 60 KI = 1, 4 00476 INCX = INCXS(KI) 00477 INCY = INCYS(KI) 00478 MX = ABS(INCX) 00479 MY = ABS(INCY) 00480 * 00481 DO 40 KN = 1, 4 00482 N = NS(KN) 00483 KSIZE = MIN(2,KN) 00484 LENX = LENS(KN,MX) 00485 LENY = LENS(KN,MY) 00486 * .. initialize all argument arrays .. 00487 DO 20 I = 1, 7 00488 CX(I) = CX1(I) 00489 CY(I) = CY1(I) 00490 20 CONTINUE 00491 IF (ICASE.EQ.1) THEN 00492 * .. CDOTC .. 00493 CDOT(1) = CDOTC(N,CX,INCX,CY,INCY) 00494 CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) 00495 ELSE IF (ICASE.EQ.2) THEN 00496 * .. CDOTU .. 00497 CDOT(1) = CDOTU(N,CX,INCX,CY,INCY) 00498 CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) 00499 ELSE IF (ICASE.EQ.3) THEN 00500 * .. CAXPY .. 00501 CALL CAXPY(N,CA,CX,INCX,CY,INCY) 00502 CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC) 00503 ELSE IF (ICASE.EQ.4) THEN 00504 * .. CCOPY .. 00505 CALL CCOPY(N,CX,INCX,CY,INCY) 00506 CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) 00507 ELSE IF (ICASE.EQ.5) THEN 00508 * .. CSWAP .. 00509 CALL CSWAP(N,CX,INCX,CY,INCY) 00510 CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0E0) 00511 CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) 00512 ELSE 00513 WRITE (NOUT,*) ' Shouldn''t be here in CHECK2' 00514 STOP 00515 END IF 00516 * 00517 40 CONTINUE 00518 60 CONTINUE 00519 RETURN 00520 END 00521 SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC) 00522 * ********************************* STEST ************************** 00523 * 00524 * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO 00525 * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE 00526 * NEGLIGIBLE. 00527 * 00528 * C. L. LAWSON, JPL, 1974 DEC 10 00529 * 00530 * .. Parameters .. 00531 INTEGER NOUT 00532 PARAMETER (NOUT=6) 00533 * .. Scalar Arguments .. 00534 REAL SFAC 00535 INTEGER LEN 00536 * .. Array Arguments .. 00537 REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) 00538 * .. Scalars in Common .. 00539 INTEGER ICASE, INCX, INCY, MODE, N 00540 LOGICAL PASS 00541 * .. Local Scalars .. 00542 REAL SD 00543 INTEGER I 00544 * .. External Functions .. 00545 REAL SDIFF 00546 EXTERNAL SDIFF 00547 * .. Intrinsic Functions .. 00548 INTRINSIC ABS 00549 * .. Common blocks .. 00550 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00551 * .. Executable Statements .. 00552 * 00553 DO 40 I = 1, LEN 00554 SD = SCOMP(I) - STRUE(I) 00555 IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0E0) 00556 + GO TO 40 00557 * 00558 * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I). 00559 * 00560 IF ( .NOT. PASS) GO TO 20 00561 * PRINT FAIL MESSAGE AND HEADER. 00562 PASS = .FALSE. 00563 WRITE (NOUT,99999) 00564 WRITE (NOUT,99998) 00565 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I), 00566 + STRUE(I), SD, SSIZE(I) 00567 40 CONTINUE 00568 RETURN 00569 * 00570 99999 FORMAT (' FAIL') 00571 99998 FORMAT (/' CASE N INCX INCY MODE I ', 00572 + ' COMP(I) TRUE(I) DIFFERENCE', 00573 + ' SIZE(I)',/1X) 00574 99997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.4) 00575 END 00576 SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC) 00577 * ************************* STEST1 ***************************** 00578 * 00579 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN 00580 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE 00581 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT. 00582 * 00583 * C.L. LAWSON, JPL, 1978 DEC 6 00584 * 00585 * .. Scalar Arguments .. 00586 REAL SCOMP1, SFAC, STRUE1 00587 * .. Array Arguments .. 00588 REAL SSIZE(*) 00589 * .. Local Arrays .. 00590 REAL SCOMP(1), STRUE(1) 00591 * .. External Subroutines .. 00592 EXTERNAL STEST 00593 * .. Executable Statements .. 00594 * 00595 SCOMP(1) = SCOMP1 00596 STRUE(1) = STRUE1 00597 CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC) 00598 * 00599 RETURN 00600 END 00601 REAL FUNCTION SDIFF(SA,SB) 00602 * ********************************* SDIFF ************************** 00603 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 00604 * 00605 * .. Scalar Arguments .. 00606 REAL SA, SB 00607 * .. Executable Statements .. 00608 SDIFF = SA - SB 00609 RETURN 00610 END 00611 SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC) 00612 * **************************** CTEST ***************************** 00613 * 00614 * C.L. LAWSON, JPL, 1978 DEC 6 00615 * 00616 * .. Scalar Arguments .. 00617 REAL SFAC 00618 INTEGER LEN 00619 * .. Array Arguments .. 00620 COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN) 00621 * .. Local Scalars .. 00622 INTEGER I 00623 * .. Local Arrays .. 00624 REAL SCOMP(20), SSIZE(20), STRUE(20) 00625 * .. External Subroutines .. 00626 EXTERNAL STEST 00627 * .. Intrinsic Functions .. 00628 INTRINSIC AIMAG, REAL 00629 * .. Executable Statements .. 00630 DO 20 I = 1, LEN 00631 SCOMP(2*I-1) = REAL(CCOMP(I)) 00632 SCOMP(2*I) = AIMAG(CCOMP(I)) 00633 STRUE(2*I-1) = REAL(CTRUE(I)) 00634 STRUE(2*I) = AIMAG(CTRUE(I)) 00635 SSIZE(2*I-1) = REAL(CSIZE(I)) 00636 SSIZE(2*I) = AIMAG(CSIZE(I)) 00637 20 CONTINUE 00638 * 00639 CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC) 00640 RETURN 00641 END 00642 SUBROUTINE ITEST1(ICOMP,ITRUE) 00643 * ********************************* ITEST1 ************************* 00644 * 00645 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR 00646 * EQUALITY. 00647 * C. L. LAWSON, JPL, 1974 DEC 10 00648 * 00649 * .. Parameters .. 00650 INTEGER NOUT 00651 PARAMETER (NOUT=6) 00652 * .. Scalar Arguments .. 00653 INTEGER ICOMP, ITRUE 00654 * .. Scalars in Common .. 00655 INTEGER ICASE, INCX, INCY, MODE, N 00656 LOGICAL PASS 00657 * .. Local Scalars .. 00658 INTEGER ID 00659 * .. Common blocks .. 00660 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS 00661 * .. Executable Statements .. 00662 IF (ICOMP.EQ.ITRUE) GO TO 40 00663 * 00664 * HERE ICOMP IS NOT EQUAL TO ITRUE. 00665 * 00666 IF ( .NOT. PASS) GO TO 20 00667 * PRINT FAIL MESSAGE AND HEADER. 00668 PASS = .FALSE. 00669 WRITE (NOUT,99999) 00670 WRITE (NOUT,99998) 00671 20 ID = ICOMP - ITRUE 00672 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID 00673 40 CONTINUE 00674 RETURN 00675 * 00676 99999 FORMAT (' FAIL') 00677 99998 FORMAT (/' CASE N INCX INCY MODE ', 00678 + ' COMP TRUE DIFFERENCE', 00679 + /1X) 00680 99997 FORMAT (1X,I4,I3,3I5,2I36,I12) 00681 END
1.7.3 
