source: pacpussensors/trunk/Vislab/lib3dv/eigen/blas/testing/zblat1.f@ 136

Last change on this file since 136 was 136, checked in by ldecherf, 7 years ago

Doc
File size: 30.5 KB
Line 
1 PROGRAM ZBLAT1
2* Test program for the COMPLEX*16 Level 1 BLAS.
3* Based upon the original BLAS 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 DOUBLE PRECISION 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.765625D-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*
4599999 FORMAT (' Complex BLAS Test Program Results',/1X)
4699998 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*6 L(10)
57* .. Common blocks ..
58 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
59* .. Data statements ..
60 DATA L(1)/'ZDOTC '/
61 DATA L(2)/'ZDOTU '/
62 DATA L(3)/'ZAXPY '/
63 DATA L(4)/'ZCOPY '/
64 DATA L(5)/'ZSWAP '/
65 DATA L(6)/'DZNRM2'/
66 DATA L(7)/'DZASUM'/
67 DATA L(8)/'ZSCAL '/
68 DATA L(9)/'ZDSCAL'/
69 DATA L(10)/'IZAMAX'/
70* .. Executable Statements ..
71 WRITE (NOUT,99999) ICASE, L(ICASE)
72 RETURN
73*
7499999 FORMAT (/' Test of subprogram number',I3,12X,A6)
75 END
76 SUBROUTINE CHECK1(SFAC)
77* .. Parameters ..
78 INTEGER NOUT
79 PARAMETER (NOUT=6)
80* .. Scalar Arguments ..
81 DOUBLE PRECISION SFAC
82* .. Scalars in Common ..
83 INTEGER ICASE, INCX, INCY, MODE, N
84 LOGICAL PASS
85* .. Local Scalars ..
86 COMPLEX*16 CA
87 DOUBLE PRECISION SA
88 INTEGER I, J, LEN, NP1
89* .. Local Arrays ..
90 COMPLEX*16 CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8),
91 + MWPCS(5), MWPCT(5)
92 DOUBLE PRECISION STRUE2(5), STRUE4(5)
93 INTEGER ITRUE3(5)
94* .. External Functions ..
95 DOUBLE PRECISION DZASUM, DZNRM2
96 INTEGER IZAMAX
97 EXTERNAL DZASUM, DZNRM2, IZAMAX
98* .. External Subroutines ..
99 EXTERNAL ZSCAL, ZDSCAL, 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.3D0, (0.4D0,-0.7D0)/
106 DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0),
107 + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
108 + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
109 + (1.0D0,2.0D0), (0.3D0,-0.4D0), (3.0D0,4.0D0),
110 + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
111 + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
112 + (0.1D0,-0.3D0), (0.5D0,-0.1D0), (5.0D0,6.0D0),
113 + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
114 + (5.0D0,6.0D0), (5.0D0,6.0D0), (0.1D0,0.1D0),
115 + (-0.6D0,0.1D0), (0.1D0,-0.3D0), (7.0D0,8.0D0),
116 + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
117 + (7.0D0,8.0D0), (0.3D0,0.1D0), (0.1D0,0.4D0),
118 + (0.4D0,0.1D0), (0.1D0,0.2D0), (2.0D0,3.0D0),
119 + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0)/
120 DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0),
121 + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
122 + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
123 + (4.0D0,5.0D0), (0.3D0,-0.4D0), (6.0D0,7.0D0),
124 + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
125 + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
126 + (0.1D0,-0.3D0), (8.0D0,9.0D0), (0.5D0,-0.1D0),
127 + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
128 + (2.0D0,5.0D0), (2.0D0,5.0D0), (0.1D0,0.1D0),
129 + (3.0D0,6.0D0), (-0.6D0,0.1D0), (4.0D0,7.0D0),
130 + (0.1D0,-0.3D0), (7.0D0,2.0D0), (7.0D0,2.0D0),
131 + (7.0D0,2.0D0), (0.3D0,0.1D0), (5.0D0,8.0D0),
132 + (0.1D0,0.4D0), (6.0D0,9.0D0), (0.4D0,0.1D0),
133 + (8.0D0,3.0D0), (0.1D0,0.2D0), (9.0D0,4.0D0)/
134 DATA STRUE2/0.0D0, 0.5D0, 0.6D0, 0.7D0, 0.7D0/
135 DATA STRUE4/0.0D0, 0.7D0, 1.0D0, 1.3D0, 1.7D0/
136 DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0),
137 + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
138 + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
139 + (1.0D0,2.0D0), (-0.16D0,-0.37D0), (3.0D0,4.0D0),
140 + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
141 + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
142 + (-0.17D0,-0.19D0), (0.13D0,-0.39D0),
143 + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
144 + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
145 + (0.11D0,-0.03D0), (-0.17D0,0.46D0),
146 + (-0.17D0,-0.19D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
147 + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
148 + (0.19D0,-0.17D0), (0.32D0,0.09D0),
149 + (0.23D0,-0.24D0), (0.18D0,0.01D0),
150 + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0),
151 + (2.0D0,3.0D0)/
152 DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0),
153 + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
154 + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
155 + (4.0D0,5.0D0), (-0.16D0,-0.37D0), (6.0D0,7.0D0),
156 + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
157 + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
158 + (-0.17D0,-0.19D0), (8.0D0,9.0D0),
159 + (0.13D0,-0.39D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
160 + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
161 + (0.11D0,-0.03D0), (3.0D0,6.0D0),
162 + (-0.17D0,0.46D0), (4.0D0,7.0D0),
163 + (-0.17D0,-0.19D0), (7.0D0,2.0D0), (7.0D0,2.0D0),
164 + (7.0D0,2.0D0), (0.19D0,-0.17D0), (5.0D0,8.0D0),
165 + (0.32D0,0.09D0), (6.0D0,9.0D0),
166 + (0.23D0,-0.24D0), (8.0D0,3.0D0),
167 + (0.18D0,0.01D0), (9.0D0,4.0D0)/
168 DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1D0,0.1D0),
169 + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
170 + (1.0D0,2.0D0), (1.0D0,2.0D0), (1.0D0,2.0D0),
171 + (1.0D0,2.0D0), (0.09D0,-0.12D0), (3.0D0,4.0D0),
172 + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
173 + (3.0D0,4.0D0), (3.0D0,4.0D0), (3.0D0,4.0D0),
174 + (0.03D0,-0.09D0), (0.15D0,-0.03D0),
175 + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
176 + (5.0D0,6.0D0), (5.0D0,6.0D0), (5.0D0,6.0D0),
177 + (0.03D0,0.03D0), (-0.18D0,0.03D0),
178 + (0.03D0,-0.09D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
179 + (7.0D0,8.0D0), (7.0D0,8.0D0), (7.0D0,8.0D0),
180 + (0.09D0,0.03D0), (0.03D0,0.12D0),
181 + (0.12D0,0.03D0), (0.03D0,0.06D0), (2.0D0,3.0D0),
182 + (2.0D0,3.0D0), (2.0D0,3.0D0), (2.0D0,3.0D0)/
183 DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1D0,0.1D0),
184 + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
185 + (4.0D0,5.0D0), (4.0D0,5.0D0), (4.0D0,5.0D0),
186 + (4.0D0,5.0D0), (0.09D0,-0.12D0), (6.0D0,7.0D0),
187 + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
188 + (6.0D0,7.0D0), (6.0D0,7.0D0), (6.0D0,7.0D0),
189 + (0.03D0,-0.09D0), (8.0D0,9.0D0),
190 + (0.15D0,-0.03D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
191 + (2.0D0,5.0D0), (2.0D0,5.0D0), (2.0D0,5.0D0),
192 + (0.03D0,0.03D0), (3.0D0,6.0D0),
193 + (-0.18D0,0.03D0), (4.0D0,7.0D0),
194 + (0.03D0,-0.09D0), (7.0D0,2.0D0), (7.0D0,2.0D0),
195 + (7.0D0,2.0D0), (0.09D0,0.03D0), (5.0D0,8.0D0),
196 + (0.03D0,0.12D0), (6.0D0,9.0D0), (0.12D0,0.03D0),
197 + (8.0D0,3.0D0), (0.03D0,0.06D0), (9.0D0,4.0D0)/
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* .. DZNRM2 ..
210 CALL STEST1(DZNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1),
211 + SFAC)
212 ELSE IF (ICASE.EQ.7) THEN
213* .. DZASUM ..
214 CALL STEST1(DZASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1),
215 + SFAC)
216 ELSE IF (ICASE.EQ.8) THEN
217* .. ZSCAL ..
218 CALL ZSCAL(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* .. ZDSCAL ..
223 CALL ZDSCAL(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* .. IZAMAX ..
228 CALL ITEST1(IZAMAX(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* ZSCAL
240* Add a test for alpha equal to zero.
241 CA = (0.0D0,0.0D0)
242 DO 80 I = 1, 5
243 MWPCT(I) = (0.0D0,0.0D0)
244 MWPCS(I) = (1.0D0,1.0D0)
245 80 CONTINUE
246 CALL ZSCAL(5,CA,CX,INCX)
247 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
248 ELSE IF (ICASE.EQ.9) THEN
249* ZDSCAL
250* Add a test for alpha equal to zero.
251 SA = 0.0D0
252 DO 100 I = 1, 5
253 MWPCT(I) = (0.0D0,0.0D0)
254 MWPCS(I) = (1.0D0,1.0D0)
255 100 CONTINUE
256 CALL ZDSCAL(5,SA,CX,INCX)
257 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
258* Add a test for alpha equal to one.
259 SA = 1.0D0
260 DO 120 I = 1, 5
261 MWPCT(I) = CX(I)
262 MWPCS(I) = CX(I)
263 120 CONTINUE
264 CALL ZDSCAL(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.0D0
268 DO 140 I = 1, 5
269 MWPCT(I) = -CX(I)
270 MWPCS(I) = -CX(I)
271 140 CONTINUE
272 CALL ZDSCAL(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 DOUBLE PRECISION SFAC
283* .. Scalars in Common ..
284 INTEGER ICASE, INCX, INCY, MODE, N
285 LOGICAL PASS
286* .. Local Scalars ..
287 COMPLEX*16 CA
288 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
289* .. Local Arrays ..
290 COMPLEX*16 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 COMPLEX*16 ZDOTC, ZDOTU
296 EXTERNAL ZDOTC, ZDOTU
297* .. External Subroutines ..
298 EXTERNAL ZAXPY, ZCOPY, ZSWAP, CTEST
299* .. Intrinsic Functions ..
300 INTRINSIC ABS, MIN
301* .. Common blocks ..
302 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
303* .. Data statements ..
304 DATA CA/(0.4D0,-0.7D0)/
305 DATA INCXS/1, 2, -2, -1/
306 DATA INCYS/1, -2, 1, -2/
307 DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
308 DATA NS/0, 1, 2, 4/
309 DATA CX1/(0.7D0,-0.8D0), (-0.4D0,-0.7D0),
310 + (-0.1D0,-0.9D0), (0.2D0,-0.8D0),
311 + (-0.9D0,-0.4D0), (0.1D0,0.4D0), (-0.6D0,0.6D0)/
312 DATA CY1/(0.6D0,-0.6D0), (-0.9D0,0.5D0),
313 + (0.7D0,-0.6D0), (0.1D0,-0.5D0), (-0.1D0,-0.2D0),
314 + (-0.5D0,-0.3D0), (0.8D0,-0.7D0)/
315 DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6D0,-0.6D0),
316 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
317 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
318 + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
319 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
320 + (0.0D0,0.0D0), (0.32D0,-1.41D0),
321 + (-1.55D0,0.5D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
322 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
323 + (0.32D0,-1.41D0), (-1.55D0,0.5D0),
324 + (0.03D0,-0.89D0), (-0.38D0,-0.96D0),
325 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/
326 DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6D0,-0.6D0),
327 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
328 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
329 + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
330 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
331 + (0.0D0,0.0D0), (-0.07D0,-0.89D0),
332 + (-0.9D0,0.5D0), (0.42D0,-1.41D0), (0.0D0,0.0D0),
333 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
334 + (0.78D0,0.06D0), (-0.9D0,0.5D0),
335 + (0.06D0,-0.13D0), (0.1D0,-0.5D0),
336 + (-0.77D0,-0.49D0), (-0.5D0,-0.3D0),
337 + (0.52D0,-1.51D0)/
338 DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6D0,-0.6D0),
339 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
340 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
341 + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
342 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
343 + (0.0D0,0.0D0), (-0.07D0,-0.89D0),
344 + (-1.18D0,-0.31D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
345 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
346 + (0.78D0,0.06D0), (-1.54D0,0.97D0),
347 + (0.03D0,-0.89D0), (-0.18D0,-1.31D0),
348 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/
349 DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6D0,-0.6D0),
350 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
351 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
352 + (0.32D0,-1.41D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
353 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
354 + (0.0D0,0.0D0), (0.32D0,-1.41D0), (-0.9D0,0.5D0),
355 + (0.05D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
356 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.32D0,-1.41D0),
357 + (-0.9D0,0.5D0), (0.05D0,-0.6D0), (0.1D0,-0.5D0),
358 + (-0.77D0,-0.49D0), (-0.5D0,-0.3D0),
359 + (0.32D0,-1.16D0)/
360 DATA CT7/(0.0D0,0.0D0), (-0.06D0,-0.90D0),
361 + (0.65D0,-0.47D0), (-0.34D0,-1.22D0),
362 + (0.0D0,0.0D0), (-0.06D0,-0.90D0),
363 + (-0.59D0,-1.46D0), (-1.04D0,-0.04D0),
364 + (0.0D0,0.0D0), (-0.06D0,-0.90D0),
365 + (-0.83D0,0.59D0), (0.07D0,-0.37D0),
366 + (0.0D0,0.0D0), (-0.06D0,-0.90D0),
367 + (-0.76D0,-1.15D0), (-1.33D0,-1.82D0)/
368 DATA CT6/(0.0D0,0.0D0), (0.90D0,0.06D0),
369 + (0.91D0,-0.77D0), (1.80D0,-0.10D0),
370 + (0.0D0,0.0D0), (0.90D0,0.06D0), (1.45D0,0.74D0),
371 + (0.20D0,0.90D0), (0.0D0,0.0D0), (0.90D0,0.06D0),
372 + (-0.55D0,0.23D0), (0.83D0,-0.39D0),
373 + (0.0D0,0.0D0), (0.90D0,0.06D0), (1.04D0,0.79D0),
374 + (1.95D0,1.22D0)/
375 DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7D0,-0.8D0),
376 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
377 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
378 + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
379 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
380 + (0.0D0,0.0D0), (0.6D0,-0.6D0), (-0.9D0,0.5D0),
381 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
382 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.6D0,-0.6D0),
383 + (-0.9D0,0.5D0), (0.7D0,-0.6D0), (0.1D0,-0.5D0),
384 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/
385 DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7D0,-0.8D0),
386 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
387 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
388 + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
389 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
390 + (0.0D0,0.0D0), (0.7D0,-0.6D0), (-0.4D0,-0.7D0),
391 + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
392 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.8D0,-0.7D0),
393 + (-0.4D0,-0.7D0), (-0.1D0,-0.2D0),
394 + (0.2D0,-0.8D0), (0.7D0,-0.6D0), (0.1D0,0.4D0),
395 + (0.6D0,-0.6D0)/
396 DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7D0,-0.8D0),
397 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
398 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
399 + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
400 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
401 + (0.0D0,0.0D0), (-0.9D0,0.5D0), (-0.4D0,-0.7D0),
402 + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
403 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.1D0,-0.5D0),
404 + (-0.4D0,-0.7D0), (0.7D0,-0.6D0), (0.2D0,-0.8D0),
405 + (-0.9D0,0.5D0), (0.1D0,0.4D0), (0.6D0,-0.6D0)/
406 DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7D0,-0.8D0),
407 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
408 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
409 + (0.6D0,-0.6D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
410 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
411 + (0.0D0,0.0D0), (0.6D0,-0.6D0), (0.7D0,-0.6D0),
412 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
413 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.6D0,-0.6D0),
414 + (0.7D0,-0.6D0), (-0.1D0,-0.2D0), (0.8D0,-0.7D0),
415 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0)/
416 DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6D0,-0.6D0),
417 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
418 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
419 + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
420 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
421 + (0.0D0,0.0D0), (0.7D0,-0.8D0), (-0.4D0,-0.7D0),
422 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
423 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.7D0,-0.8D0),
424 + (-0.4D0,-0.7D0), (-0.1D0,-0.9D0),
425 + (0.2D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
426 + (0.0D0,0.0D0)/
427 DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6D0,-0.6D0),
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.7D0,-0.8D0), (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.1D0,-0.9D0), (-0.9D0,0.5D0),
433 + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
434 + (0.0D0,0.0D0), (0.0D0,0.0D0), (-0.6D0,0.6D0),
435 + (-0.9D0,0.5D0), (-0.9D0,-0.4D0), (0.1D0,-0.5D0),
436 + (-0.1D0,-0.9D0), (-0.5D0,-0.3D0),
437 + (0.7D0,-0.8D0)/
438 DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6D0,-0.6D0),
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.7D0,-0.8D0), (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.1D0,-0.9D0), (0.7D0,-0.8D0),
444 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
445 + (0.0D0,0.0D0), (0.0D0,0.0D0), (-0.6D0,0.6D0),
446 + (-0.9D0,-0.4D0), (-0.1D0,-0.9D0),
447 + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
448 + (0.0D0,0.0D0)/
449 DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6D0,-0.6D0),
450 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
451 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
452 + (0.7D0,-0.8D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
453 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
454 + (0.0D0,0.0D0), (0.7D0,-0.8D0), (-0.9D0,0.5D0),
455 + (-0.4D0,-0.7D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
456 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.7D0,-0.8D0),
457 + (-0.9D0,0.5D0), (-0.4D0,-0.7D0), (0.1D0,-0.5D0),
458 + (-0.1D0,-0.9D0), (-0.5D0,-0.3D0),
459 + (0.2D0,-0.8D0)/
460 DATA CSIZE1/(0.0D0,0.0D0), (0.9D0,0.9D0),
461 + (1.63D0,1.73D0), (2.90D0,2.78D0)/
462 DATA CSIZE3/(0.0D0,0.0D0), (0.0D0,0.0D0),
463 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
464 + (0.0D0,0.0D0), (0.0D0,0.0D0), (1.17D0,1.17D0),
465 + (1.17D0,1.17D0), (1.17D0,1.17D0),
466 + (1.17D0,1.17D0), (1.17D0,1.17D0),
467 + (1.17D0,1.17D0), (1.17D0,1.17D0)/
468 DATA CSIZE2/(0.0D0,0.0D0), (0.0D0,0.0D0),
469 + (0.0D0,0.0D0), (0.0D0,0.0D0), (0.0D0,0.0D0),
470 + (0.0D0,0.0D0), (0.0D0,0.0D0), (1.54D0,1.54D0),
471 + (1.54D0,1.54D0), (1.54D0,1.54D0),
472 + (1.54D0,1.54D0), (1.54D0,1.54D0),
473 + (1.54D0,1.54D0), (1.54D0,1.54D0)/
474* .. Executable Statements ..
475 DO 60 KI = 1, 4
476 INCX = INCXS(KI)
477 INCY = INCYS(KI)
478 MX = ABS(INCX)
479 MY = ABS(INCY)
480*
481 DO 40 KN = 1, 4
482 N = NS(KN)
483 KSIZE = MIN(2,KN)
484 LENX = LENS(KN,MX)
485 LENY = LENS(KN,MY)
486* .. initialize all argument arrays ..
487 DO 20 I = 1, 7
488 CX(I) = CX1(I)
489 CY(I) = CY1(I)
490 20 CONTINUE
491 IF (ICASE.EQ.1) THEN
492* .. ZDOTC ..
493 CDOT(1) = ZDOTC(N,CX,INCX,CY,INCY)
494 CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC)
495 ELSE IF (ICASE.EQ.2) THEN
496* .. ZDOTU ..
497 CDOT(1) = ZDOTU(N,CX,INCX,CY,INCY)
498 CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC)
499 ELSE IF (ICASE.EQ.3) THEN
500* .. ZAXPY ..
501 CALL ZAXPY(N,CA,CX,INCX,CY,INCY)
502 CALL CTEST(LENY,CY,CT8(1,KN,KI),CSIZE2(1,KSIZE),SFAC)
503 ELSE IF (ICASE.EQ.4) THEN
504* .. ZCOPY ..
505 CALL ZCOPY(N,CX,INCX,CY,INCY)
506 CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0)
507 ELSE IF (ICASE.EQ.5) THEN
508* .. ZSWAP ..
509 CALL ZSWAP(N,CX,INCX,CY,INCY)
510 CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0D0)
511 CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0D0)
512 ELSE
513 WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
514 STOP
515 END IF
516*
517 40 CONTINUE
518 60 CONTINUE
519 RETURN
520 END
521 SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
522* ********************************* STEST **************************
523*
524* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
525* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
526* NEGLIGIBLE.
527*
528* C. L. LAWSON, JPL, 1974 DEC 10
529*
530* .. Parameters ..
531 INTEGER NOUT
532 PARAMETER (NOUT=6)
533* .. Scalar Arguments ..
534 DOUBLE PRECISION SFAC
535 INTEGER LEN
536* .. Array Arguments ..
537 DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
538* .. Scalars in Common ..
539 INTEGER ICASE, INCX, INCY, MODE, N
540 LOGICAL PASS
541* .. Local Scalars ..
542 DOUBLE PRECISION SD
543 INTEGER I
544* .. External Functions ..
545 DOUBLE PRECISION SDIFF
546 EXTERNAL SDIFF
547* .. Intrinsic Functions ..
548 INTRINSIC ABS
549* .. Common blocks ..
550 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
551* .. Executable Statements ..
552*
553 DO 40 I = 1, LEN
554 SD = SCOMP(I) - STRUE(I)
555 IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0D0)
556 + GO TO 40
557*
558* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
559*
560 IF ( .NOT. PASS) GO TO 20
561* PRINT FAIL MESSAGE AND HEADER.
562 PASS = .FALSE.
563 WRITE (NOUT,99999)
564 WRITE (NOUT,99998)
565 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I),
566 + STRUE(I), SD, SSIZE(I)
567 40 CONTINUE
568 RETURN
569*
57099999 FORMAT (' FAIL')
57199998 FORMAT (/' CASE N INCX INCY MODE I ',
572 + ' COMP(I) TRUE(I) DIFFERENCE',
573 + ' SIZE(I)',/1X)
57499997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4)
575 END
576 SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
577* ************************* STEST1 *****************************
578*
579* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
580* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
581* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
582*
583* C.L. LAWSON, JPL, 1978 DEC 6
584*
585* .. Scalar Arguments ..
586 DOUBLE PRECISION SCOMP1, SFAC, STRUE1
587* .. Array Arguments ..
588 DOUBLE PRECISION SSIZE(*)
589* .. Local Arrays ..
590 DOUBLE PRECISION SCOMP(1), STRUE(1)
591* .. External Subroutines ..
592 EXTERNAL STEST
593* .. Executable Statements ..
594*
595 SCOMP(1) = SCOMP1
596 STRUE(1) = STRUE1
597 CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
598*
599 RETURN
600 END
601 DOUBLE PRECISION FUNCTION SDIFF(SA,SB)
602* ********************************* SDIFF **************************
603* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
604*
605* .. Scalar Arguments ..
606 DOUBLE PRECISION SA, SB
607* .. Executable Statements ..
608 SDIFF = SA - SB
609 RETURN
610 END
611 SUBROUTINE CTEST(LEN,CCOMP,CTRUE,CSIZE,SFAC)
612* **************************** CTEST *****************************
613*
614* C.L. LAWSON, JPL, 1978 DEC 6
615*
616* .. Scalar Arguments ..
617 DOUBLE PRECISION SFAC
618 INTEGER LEN
619* .. Array Arguments ..
620 COMPLEX*16 CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
621* .. Local Scalars ..
622 INTEGER I
623* .. Local Arrays ..
624 DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20)
625* .. External Subroutines ..
626 EXTERNAL STEST
627* .. Intrinsic Functions ..
628 INTRINSIC DIMAG, DBLE
629* .. Executable Statements ..
630 DO 20 I = 1, LEN
631 SCOMP(2*I-1) = DBLE(CCOMP(I))
632 SCOMP(2*I) = DIMAG(CCOMP(I))
633 STRUE(2*I-1) = DBLE(CTRUE(I))
634 STRUE(2*I) = DIMAG(CTRUE(I))
635 SSIZE(2*I-1) = DBLE(CSIZE(I))
636 SSIZE(2*I) = DIMAG(CSIZE(I))
637 20 CONTINUE
638*
639 CALL STEST(2*LEN,SCOMP,STRUE,SSIZE,SFAC)
640 RETURN
641 END
642 SUBROUTINE ITEST1(ICOMP,ITRUE)
643* ********************************* ITEST1 *************************
644*
645* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
646* EQUALITY.
647* C. L. LAWSON, JPL, 1974 DEC 10
648*
649* .. Parameters ..
650 INTEGER NOUT
651 PARAMETER (NOUT=6)
652* .. Scalar Arguments ..
653 INTEGER ICOMP, ITRUE
654* .. Scalars in Common ..
655 INTEGER ICASE, INCX, INCY, MODE, N
656 LOGICAL PASS
657* .. Local Scalars ..
658 INTEGER ID
659* .. Common blocks ..
660 COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
661* .. Executable Statements ..
662 IF (ICOMP.EQ.ITRUE) GO TO 40
663*
664* HERE ICOMP IS NOT EQUAL TO ITRUE.
665*
666 IF ( .NOT. PASS) GO TO 20
667* PRINT FAIL MESSAGE AND HEADER.
668 PASS = .FALSE.
669 WRITE (NOUT,99999)
670 WRITE (NOUT,99998)
671 20 ID = ICOMP - ITRUE
672 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID
673 40 CONTINUE
674 RETURN
675*
67699999 FORMAT (' FAIL')
67799998 FORMAT (/' CASE N INCX INCY MODE ',
678 + ' COMP TRUE DIFFERENCE',
679 + /1X)
68099997 FORMAT (1X,I4,I3,3I5,2I36,I12)
681 END
Note: See TracBrowser for help on using the repository browser.