1*> \brief \b CBLAT1 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 CBLAT1 12* 13* 14*> \par Purpose: 15* ============= 16*> 17*> \verbatim 18*> 19*> Test program for the COMPLEX Level 1 BLAS. 20*> Based upon the original BLAS test routine together with: 21*> 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 complex_blas_testing 36* 37* ===================================================================== 38 PROGRAM CBLAT1 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 REAL 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.765625E-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* 8799999 FORMAT (' Complex BLAS Test Program Results',/1X) 8899998 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)/'CDOTC '/ 103 DATA L(2)/'CDOTU '/ 104 DATA L(3)/'CAXPY '/ 105 DATA L(4)/'CCOPY '/ 106 DATA L(5)/'CSWAP '/ 107 DATA L(6)/'SCNRM2'/ 108 DATA L(7)/'SCASUM'/ 109 DATA L(8)/'CSCAL '/ 110 DATA L(9)/'CSSCAL'/ 111 DATA L(10)/'ICAMAX'/ 112* .. Executable Statements .. 113 WRITE (NOUT,99999) ICASE, L(ICASE) 114 RETURN 115* 11699999 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 REAL SFAC 124* .. Scalars in Common .. 125 INTEGER ICASE, INCX, INCY, MODE, N 126 LOGICAL PASS 127* .. Local Scalars .. 128 COMPLEX CA 129 REAL SA 130 INTEGER I, J, LEN, NP1 131* .. Local Arrays .. 132 COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8), 133 + MWPCS(5), MWPCT(5) 134 REAL STRUE2(5), STRUE4(5) 135 INTEGER ITRUE3(5) 136* .. External Functions .. 137 REAL SCASUM, SCNRM2 138 INTEGER ICAMAX 139 EXTERNAL SCASUM, SCNRM2, ICAMAX 140* .. External Subroutines .. 141 EXTERNAL CSCAL, CSSCAL, 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.3E0, (0.4E0,-0.7E0)/ 148 DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 149 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 150 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 151 + (1.0E0,2.0E0), (0.3E0,-0.4E0), (3.0E0,4.0E0), 152 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 153 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 154 + (0.1E0,-0.3E0), (0.5E0,-0.1E0), (5.0E0,6.0E0), 155 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 156 + (5.0E0,6.0E0), (5.0E0,6.0E0), (0.1E0,0.1E0), 157 + (-0.6E0,0.1E0), (0.1E0,-0.3E0), (7.0E0,8.0E0), 158 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 159 + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.5E0,0.0E0), 160 + (0.0E0,0.5E0), (0.0E0,0.2E0), (2.0E0,3.0E0), 161 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ 162 DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 163 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 164 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 165 + (4.0E0,5.0E0), (0.3E0,-0.4E0), (6.0E0,7.0E0), 166 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 167 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 168 + (0.1E0,-0.3E0), (8.0E0,9.0E0), (0.5E0,-0.1E0), 169 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 170 + (2.0E0,5.0E0), (2.0E0,5.0E0), (0.1E0,0.1E0), 171 + (3.0E0,6.0E0), (-0.6E0,0.1E0), (4.0E0,7.0E0), 172 + (0.1E0,-0.3E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 173 + (7.0E0,2.0E0), (0.3E0,0.1E0), (5.0E0,8.0E0), 174 + (0.5E0,0.0E0), (6.0E0,9.0E0), (0.0E0,0.5E0), 175 + (8.0E0,3.0E0), (0.0E0,0.2E0), (9.0E0,4.0E0)/ 176 DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.8E0/ 177 DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.6E0/ 178 DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 179 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 180 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 181 + (1.0E0,2.0E0), (-0.16E0,-0.37E0), (3.0E0,4.0E0), 182 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 183 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 184 + (-0.17E0,-0.19E0), (0.13E0,-0.39E0), 185 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 186 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 187 + (0.11E0,-0.03E0), (-0.17E0,0.46E0), 188 + (-0.17E0,-0.19E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 189 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 190 + (0.19E0,-0.17E0), (0.20E0,-0.35E0), 191 + (0.35E0,0.20E0), (0.14E0,0.08E0), 192 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0), 193 + (2.0E0,3.0E0)/ 194 DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 195 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 196 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 197 + (4.0E0,5.0E0), (-0.16E0,-0.37E0), (6.0E0,7.0E0), 198 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 199 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 200 + (-0.17E0,-0.19E0), (8.0E0,9.0E0), 201 + (0.13E0,-0.39E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 202 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 203 + (0.11E0,-0.03E0), (3.0E0,6.0E0), 204 + (-0.17E0,0.46E0), (4.0E0,7.0E0), 205 + (-0.17E0,-0.19E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 206 + (7.0E0,2.0E0), (0.19E0,-0.17E0), (5.0E0,8.0E0), 207 + (0.20E0,-0.35E0), (6.0E0,9.0E0), 208 + (0.35E0,0.20E0), (8.0E0,3.0E0), 209 + (0.14E0,0.08E0), (9.0E0,4.0E0)/ 210 DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0), 211 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 212 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0), 213 + (1.0E0,2.0E0), (0.09E0,-0.12E0), (3.0E0,4.0E0), 214 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 215 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0), 216 + (0.03E0,-0.09E0), (0.15E0,-0.03E0), 217 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 218 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0), 219 + (0.03E0,0.03E0), (-0.18E0,0.03E0), 220 + (0.03E0,-0.09E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 221 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0), 222 + (0.09E0,0.03E0), (0.15E0,0.00E0), 223 + (0.00E0,0.15E0), (0.00E0,0.06E0), (2.0E0,3.0E0), 224 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/ 225 DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0), 226 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 227 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0), 228 + (4.0E0,5.0E0), (0.09E0,-0.12E0), (6.0E0,7.0E0), 229 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 230 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0), 231 + (0.03E0,-0.09E0), (8.0E0,9.0E0), 232 + (0.15E0,-0.03E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 233 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0), 234 + (0.03E0,0.03E0), (3.0E0,6.0E0), 235 + (-0.18E0,0.03E0), (4.0E0,7.0E0), 236 + (0.03E0,-0.09E0), (7.0E0,2.0E0), (7.0E0,2.0E0), 237 + (7.0E0,2.0E0), (0.09E0,0.03E0), (5.0E0,8.0E0), 238 + (0.15E0,0.00E0), (6.0E0,9.0E0), (0.00E0,0.15E0), 239 + (8.0E0,3.0E0), (0.00E0,0.06E0), (9.0E0,4.0E0)/ 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* .. SCNRM2 .. 252 CALL STEST1(SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1), 253 + SFAC) 254 ELSE IF (ICASE.EQ.7) THEN 255* .. SCASUM .. 256 CALL STEST1(SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1), 257 + SFAC) 258 ELSE IF (ICASE.EQ.8) THEN 259* .. CSCAL .. 260 CALL CSCAL(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* .. CSSCAL .. 265 CALL CSSCAL(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* .. ICAMAX .. 270 CALL ITEST1(ICAMAX(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* CSCAL 282* Add a test for alpha equal to zero. 283 CA = (0.0E0,0.0E0) 284 DO 80 I = 1, 5 285 MWPCT(I) = (0.0E0,0.0E0) 286 MWPCS(I) = (1.0E0,1.0E0) 287 80 CONTINUE 288 CALL CSCAL(5,CA,CX,INCX) 289 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 290 ELSE IF (ICASE.EQ.9) THEN 291* CSSCAL 292* Add a test for alpha equal to zero. 293 SA = 0.0E0 294 DO 100 I = 1, 5 295 MWPCT(I) = (0.0E0,0.0E0) 296 MWPCS(I) = (1.0E0,1.0E0) 297 100 CONTINUE 298 CALL CSSCAL(5,SA,CX,INCX) 299 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC) 300* Add a test for alpha equal to one. 301 SA = 1.0E0 302 DO 120 I = 1, 5 303 MWPCT(I) = CX(I) 304 MWPCS(I) = CX(I) 305 120 CONTINUE 306 CALL CSSCAL(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.0E0 310 DO 140 I = 1, 5 311 MWPCT(I) = -CX(I) 312 MWPCS(I) = -CX(I) 313 140 CONTINUE 314 CALL CSSCAL(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 REAL SFAC 325* .. Scalars in Common .. 326 INTEGER ICASE, INCX, INCY, MODE, N 327 LOGICAL PASS 328* .. Local Scalars .. 329 COMPLEX CA 330 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY 331* .. Local Arrays .. 332 COMPLEX 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 CDOTC, CDOTU 338 EXTERNAL CDOTC, CDOTU 339* .. External Subroutines .. 340 EXTERNAL CAXPY, CCOPY, CSWAP, 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.4E0,-0.7E0)/ 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.7E0,-0.8E0), (-0.4E0,-0.7E0), 352 + (-0.1E0,-0.9E0), (0.2E0,-0.8E0), 353 + (-0.9E0,-0.4E0), (0.1E0,0.4E0), (-0.6E0,0.6E0)/ 354 DATA CY1/(0.6E0,-0.6E0), (-0.9E0,0.5E0), 355 + (0.7E0,-0.6E0), (0.1E0,-0.5E0), (-0.1E0,-0.2E0), 356 + (-0.5E0,-0.3E0), (0.8E0,-0.7E0)/ 357 DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), 358 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 359 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 360 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 361 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 362 + (0.0E0,0.0E0), (0.32E0,-1.41E0), 363 + (-1.55E0,0.5E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 364 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 365 + (0.32E0,-1.41E0), (-1.55E0,0.5E0), 366 + (0.03E0,-0.89E0), (-0.38E0,-0.96E0), 367 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 368 DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), 369 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 370 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 371 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 372 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 373 + (0.0E0,0.0E0), (-0.07E0,-0.89E0), 374 + (-0.9E0,0.5E0), (0.42E0,-1.41E0), (0.0E0,0.0E0), 375 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 376 + (0.78E0,0.06E0), (-0.9E0,0.5E0), 377 + (0.06E0,-0.13E0), (0.1E0,-0.5E0), 378 + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), 379 + (0.52E0,-1.51E0)/ 380 DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), 381 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 382 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 383 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 384 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 385 + (0.0E0,0.0E0), (-0.07E0,-0.89E0), 386 + (-1.18E0,-0.31E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 387 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 388 + (0.78E0,0.06E0), (-1.54E0,0.97E0), 389 + (0.03E0,-0.89E0), (-0.18E0,-1.31E0), 390 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 391 DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), 392 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 393 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 394 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 395 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 396 + (0.0E0,0.0E0), (0.32E0,-1.41E0), (-0.9E0,0.5E0), 397 + (0.05E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 398 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.32E0,-1.41E0), 399 + (-0.9E0,0.5E0), (0.05E0,-0.6E0), (0.1E0,-0.5E0), 400 + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0), 401 + (0.32E0,-1.16E0)/ 402 DATA CT7/(0.0E0,0.0E0), (-0.06E0,-0.90E0), 403 + (0.65E0,-0.47E0), (-0.34E0,-1.22E0), 404 + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 405 + (-0.59E0,-1.46E0), (-1.04E0,-0.04E0), 406 + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 407 + (-0.83E0,0.59E0), (0.07E0,-0.37E0), 408 + (0.0E0,0.0E0), (-0.06E0,-0.90E0), 409 + (-0.76E0,-1.15E0), (-1.33E0,-1.82E0)/ 410 DATA CT6/(0.0E0,0.0E0), (0.90E0,0.06E0), 411 + (0.91E0,-0.77E0), (1.80E0,-0.10E0), 412 + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.45E0,0.74E0), 413 + (0.20E0,0.90E0), (0.0E0,0.0E0), (0.90E0,0.06E0), 414 + (-0.55E0,0.23E0), (0.83E0,-0.39E0), 415 + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.04E0,0.79E0), 416 + (1.95E0,1.22E0)/ 417 DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7E0,-0.8E0), 418 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 419 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 420 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 421 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 422 + (0.0E0,0.0E0), (0.6E0,-0.6E0), (-0.9E0,0.5E0), 423 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 424 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), 425 + (-0.9E0,0.5E0), (0.7E0,-0.6E0), (0.1E0,-0.5E0), 426 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 427 DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7E0,-0.8E0), 428 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 429 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 430 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 431 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 432 + (0.0E0,0.0E0), (0.7E0,-0.6E0), (-0.4E0,-0.7E0), 433 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 434 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.8E0,-0.7E0), 435 + (-0.4E0,-0.7E0), (-0.1E0,-0.2E0), 436 + (0.2E0,-0.8E0), (0.7E0,-0.6E0), (0.1E0,0.4E0), 437 + (0.6E0,-0.6E0)/ 438 DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7E0,-0.8E0), 439 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 440 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 441 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 442 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 443 + (0.0E0,0.0E0), (-0.9E0,0.5E0), (-0.4E0,-0.7E0), 444 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 445 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.1E0,-0.5E0), 446 + (-0.4E0,-0.7E0), (0.7E0,-0.6E0), (0.2E0,-0.8E0), 447 + (-0.9E0,0.5E0), (0.1E0,0.4E0), (0.6E0,-0.6E0)/ 448 DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7E0,-0.8E0), 449 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 450 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 451 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 452 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 453 + (0.0E0,0.0E0), (0.6E0,-0.6E0), (0.7E0,-0.6E0), 454 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 455 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0), 456 + (0.7E0,-0.6E0), (-0.1E0,-0.2E0), (0.8E0,-0.7E0), 457 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/ 458 DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0), 459 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 460 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 461 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 462 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 463 + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.4E0,-0.7E0), 464 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 465 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), 466 + (-0.4E0,-0.7E0), (-0.1E0,-0.9E0), 467 + (0.2E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 468 + (0.0E0,0.0E0)/ 469 DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0), 470 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 471 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 472 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 473 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 474 + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (-0.9E0,0.5E0), 475 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 476 + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), 477 + (-0.9E0,0.5E0), (-0.9E0,-0.4E0), (0.1E0,-0.5E0), 478 + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), 479 + (0.7E0,-0.8E0)/ 480 DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0), 481 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 482 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 483 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 484 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 485 + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (0.7E0,-0.8E0), 486 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 487 + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0), 488 + (-0.9E0,-0.4E0), (-0.1E0,-0.9E0), 489 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 490 + (0.0E0,0.0E0)/ 491 DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0), 492 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 493 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 494 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 495 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 496 + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.9E0,0.5E0), 497 + (-0.4E0,-0.7E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 498 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0), 499 + (-0.9E0,0.5E0), (-0.4E0,-0.7E0), (0.1E0,-0.5E0), 500 + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0), 501 + (0.2E0,-0.8E0)/ 502 DATA CSIZE1/(0.0E0,0.0E0), (0.9E0,0.9E0), 503 + (1.63E0,1.73E0), (2.90E0,2.78E0)/ 504 DATA CSIZE3/(0.0E0,0.0E0), (0.0E0,0.0E0), 505 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 506 + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.17E0,1.17E0), 507 + (1.17E0,1.17E0), (1.17E0,1.17E0), 508 + (1.17E0,1.17E0), (1.17E0,1.17E0), 509 + (1.17E0,1.17E0), (1.17E0,1.17E0)/ 510 DATA CSIZE2/(0.0E0,0.0E0), (0.0E0,0.0E0), 511 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0), 512 + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.54E0,1.54E0), 513 + (1.54E0,1.54E0), (1.54E0,1.54E0), 514 + (1.54E0,1.54E0), (1.54E0,1.54E0), 515 + (1.54E0,1.54E0), (1.54E0,1.54E0)/ 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* .. CDOTC .. 535 CDOT(1) = CDOTC(N,CX,INCX,CY,INCY) 536 CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC) 537 ELSE IF (ICASE.EQ.2) THEN 538* .. CDOTU .. 539 CDOT(1) = CDOTU(N,CX,INCX,CY,INCY) 540 CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC) 541 ELSE IF (ICASE.EQ.3) THEN 542* .. CAXPY .. 543 CALL CAXPY(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* .. CCOPY .. 547 CALL CCOPY(N,CX,INCX,CY,INCY) 548 CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) 549 ELSE IF (ICASE.EQ.5) THEN 550* .. CSWAP .. 551 CALL CSWAP(N,CX,INCX,CY,INCY) 552 CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0E0) 553 CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0) 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 REAL ZERO 575 PARAMETER (NOUT=6, ZERO=0.0E0) 576* .. Scalar Arguments .. 577 REAL SFAC 578 INTEGER LEN 579* .. Array Arguments .. 580 REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN) 581* .. Scalars in Common .. 582 INTEGER ICASE, INCX, INCY, MODE, N 583 LOGICAL PASS 584* .. Local Scalars .. 585 REAL SD 586 INTEGER I 587* .. External Functions .. 588 REAL 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* 61399999 FORMAT (' FAIL') 61499998 FORMAT (/' CASE N INCX INCY MODE I ', 615 + ' COMP(I) TRUE(I) DIFFERENCE', 616 + ' SIZE(I)',/1X) 61799997 FORMAT (1X,I4,I3,3I5,I3,2E36.8,2E12.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 REAL SCOMP1, SFAC, STRUE1 630* .. Array Arguments .. 631 REAL SSIZE(*) 632* .. Local Arrays .. 633 REAL 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 REAL FUNCTION SDIFF(SA,SB) 645* ********************************* SDIFF ************************** 646* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15 647* 648* .. Scalar Arguments .. 649 REAL 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 REAL SFAC 661 INTEGER LEN 662* .. Array Arguments .. 663 COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN) 664* .. Local Scalars .. 665 INTEGER I 666* .. Local Arrays .. 667 REAL SCOMP(20), SSIZE(20), STRUE(20) 668* .. External Subroutines .. 669 EXTERNAL STEST 670* .. Intrinsic Functions .. 671 INTRINSIC AIMAG, REAL 672* .. Executable Statements .. 673 DO 20 I = 1, LEN 674 SCOMP(2*I-1) = REAL(CCOMP(I)) 675 SCOMP(2*I) = AIMAG(CCOMP(I)) 676 STRUE(2*I-1) = REAL(CTRUE(I)) 677 STRUE(2*I) = AIMAG(CTRUE(I)) 678 SSIZE(2*I-1) = REAL(CSIZE(I)) 679 SSIZE(2*I) = AIMAG(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* 71999999 FORMAT (' FAIL') 72099998 FORMAT (/' CASE N INCX INCY MODE ', 721 + ' COMP TRUE DIFFERENCE', 722 + /1X) 72399997 FORMAT (1X,I4,I3,3I5,2I36,I12) 724 END 725