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