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