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