LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
c_zblat1.f
Go to the documentation of this file.
1 PROGRAM zcblat1
2* Test program for the COMPLEX*16 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 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 CBLAS 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*15 L(10)
57* .. Common blocks ..
58 COMMON /combla/icase, n, incx, incy, mode, pass
59* .. Data statements ..
60 DATA l(1)/'CBLAS_ZDOTC'/
61 DATA l(2)/'CBLAS_ZDOTU'/
62 DATA l(3)/'CBLAS_ZAXPY'/
63 DATA l(4)/'CBLAS_ZCOPY'/
64 DATA l(5)/'CBLAS_ZSWAP'/
65 DATA l(6)/'CBLAS_DZNRM2'/
66 DATA l(7)/'CBLAS_DZASUM'/
67 DATA l(8)/'CBLAS_ZSCAL'/
68 DATA l(9)/'CBLAS_ZDSCAL'/
69 DATA l(10)/'CBLAS_IZAMAX'/
70* .. Executable Statements ..
71 WRITE (nout,99999) icase, l(icase)
72 RETURN
73*
7499999 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 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 DZASUMTEST, DZNRM2TEST
96 INTEGER IZAMAXTEST
97 EXTERNAL dzasumtest, dznrm2test, izamaxtest
98* .. External Subroutines ..
99 EXTERNAL zscaltest, zdscaltest, 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* .. DZNRM2TEST ..
210 CALL stest1(dznrm2test(n,cx,incx),strue2(np1),
211 + strue2(np1),sfac)
212 ELSE IF (icase.EQ.7) THEN
213* .. DZASUMTEST ..
214 CALL stest1(dzasumtest(n,cx,incx),strue4(np1),
215 + strue4(np1),sfac)
216 ELSE IF (icase.EQ.8) THEN
217* .. ZSCALTEST ..
218 CALL zscaltest(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* .. ZDSCALTEST ..
223 CALL zdscaltest(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* .. IZAMAXTEST ..
228 CALL itest1(izamaxtest(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* ZSCALTEST
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 zscaltest(5,ca,cx,incx)
247 CALL ctest(5,cx,mwpct,mwpcs,sfac)
248 ELSE IF (icase.EQ.9) THEN
249* ZDSCALTEST
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 zdscaltest(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 zdscaltest(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 zdscaltest(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,ZTEMP
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 EXTERNAL zdotctest, zdotutest
296* .. External Subroutines ..
297 EXTERNAL zaxpytest, zcopytest, zswaptest, 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.4d0,-0.7d0)/
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.7d0,-0.8d0), (-0.4d0,-0.7d0),
309 + (-0.1d0,-0.9d0), (0.2d0,-0.8d0),
310 + (-0.9d0,-0.4d0), (0.1d0,0.4d0), (-0.6d0,0.6d0)/
311 DATA cy1/(0.6d0,-0.6d0), (-0.9d0,0.5d0),
312 + (0.7d0,-0.6d0), (0.1d0,-0.5d0), (-0.1d0,-0.2d0),
313 + (-0.5d0,-0.3d0), (0.8d0,-0.7d0)/
314 DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
315 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
316 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
317 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
318 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
319 + (0.0d0,0.0d0), (0.32d0,-1.41d0),
320 + (-1.55d0,0.5d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
321 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
322 + (0.32d0,-1.41d0), (-1.55d0,0.5d0),
323 + (0.03d0,-0.89d0), (-0.38d0,-0.96d0),
324 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
325 DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
326 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
327 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
328 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
329 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
330 + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
331 + (-0.9d0,0.5d0), (0.42d0,-1.41d0), (0.0d0,0.0d0),
332 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
333 + (0.78d0,0.06d0), (-0.9d0,0.5d0),
334 + (0.06d0,-0.13d0), (0.1d0,-0.5d0),
335 + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
336 + (0.52d0,-1.51d0)/
337 DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
338 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
339 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
340 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
341 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
342 + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
343 + (-1.18d0,-0.31d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
344 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
345 + (0.78d0,0.06d0), (-1.54d0,0.97d0),
346 + (0.03d0,-0.89d0), (-0.18d0,-1.31d0),
347 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
348 DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
349 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
350 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
351 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
352 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
353 + (0.0d0,0.0d0), (0.32d0,-1.41d0), (-0.9d0,0.5d0),
354 + (0.05d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
355 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.32d0,-1.41d0),
356 + (-0.9d0,0.5d0), (0.05d0,-0.6d0), (0.1d0,-0.5d0),
357 + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
358 + (0.32d0,-1.16d0)/
359 DATA ct7/(0.0d0,0.0d0), (-0.06d0,-0.90d0),
360 + (0.65d0,-0.47d0), (-0.34d0,-1.22d0),
361 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
362 + (-0.59d0,-1.46d0), (-1.04d0,-0.04d0),
363 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
364 + (-0.83d0,0.59d0), (0.07d0,-0.37d0),
365 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
366 + (-0.76d0,-1.15d0), (-1.33d0,-1.82d0)/
367 DATA ct6/(0.0d0,0.0d0), (0.90d0,0.06d0),
368 + (0.91d0,-0.77d0), (1.80d0,-0.10d0),
369 + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.45d0,0.74d0),
370 + (0.20d0,0.90d0), (0.0d0,0.0d0), (0.90d0,0.06d0),
371 + (-0.55d0,0.23d0), (0.83d0,-0.39d0),
372 + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.04d0,0.79d0),
373 + (1.95d0,1.22d0)/
374 DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7d0,-0.8d0),
375 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
376 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
377 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
378 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
379 + (0.0d0,0.0d0), (0.6d0,-0.6d0), (-0.9d0,0.5d0),
380 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
381 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
382 + (-0.9d0,0.5d0), (0.7d0,-0.6d0), (0.1d0,-0.5d0),
383 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
384 DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7d0,-0.8d0),
385 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
386 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
387 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
388 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
389 + (0.0d0,0.0d0), (0.7d0,-0.6d0), (-0.4d0,-0.7d0),
390 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
391 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.8d0,-0.7d0),
392 + (-0.4d0,-0.7d0), (-0.1d0,-0.2d0),
393 + (0.2d0,-0.8d0), (0.7d0,-0.6d0), (0.1d0,0.4d0),
394 + (0.6d0,-0.6d0)/
395 DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7d0,-0.8d0),
396 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
397 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
398 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
399 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
400 + (0.0d0,0.0d0), (-0.9d0,0.5d0), (-0.4d0,-0.7d0),
401 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
402 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.1d0,-0.5d0),
403 + (-0.4d0,-0.7d0), (0.7d0,-0.6d0), (0.2d0,-0.8d0),
404 + (-0.9d0,0.5d0), (0.1d0,0.4d0), (0.6d0,-0.6d0)/
405 DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7d0,-0.8d0),
406 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
407 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
408 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
409 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
410 + (0.0d0,0.0d0), (0.6d0,-0.6d0), (0.7d0,-0.6d0),
411 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
412 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
413 + (0.7d0,-0.6d0), (-0.1d0,-0.2d0), (0.8d0,-0.7d0),
414 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
415 DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
416 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
417 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
418 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
419 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
420 + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.4d0,-0.7d0),
421 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
422 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
423 + (-0.4d0,-0.7d0), (-0.1d0,-0.9d0),
424 + (0.2d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
425 + (0.0d0,0.0d0)/
426 DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
427 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
428 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
429 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
430 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
431 + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (-0.9d0,0.5d0),
432 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
433 + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
434 + (-0.9d0,0.5d0), (-0.9d0,-0.4d0), (0.1d0,-0.5d0),
435 + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
436 + (0.7d0,-0.8d0)/
437 DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
438 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
439 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
440 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
441 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
442 + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (0.7d0,-0.8d0),
443 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
444 + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
445 + (-0.9d0,-0.4d0), (-0.1d0,-0.9d0),
446 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
447 + (0.0d0,0.0d0)/
448 DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
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.7d0,-0.8d0), (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.7d0,-0.8d0), (-0.9d0,0.5d0),
454 + (-0.4d0,-0.7d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
455 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
456 + (-0.9d0,0.5d0), (-0.4d0,-0.7d0), (0.1d0,-0.5d0),
457 + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
458 + (0.2d0,-0.8d0)/
459 DATA csize1/(0.0d0,0.0d0), (0.9d0,0.9d0),
460 + (1.63d0,1.73d0), (2.90d0,2.78d0)/
461 DATA csize3/(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.0d0,0.0d0), (1.17d0,1.17d0),
464 + (1.17d0,1.17d0), (1.17d0,1.17d0),
465 + (1.17d0,1.17d0), (1.17d0,1.17d0),
466 + (1.17d0,1.17d0), (1.17d0,1.17d0)/
467 DATA csize2/(0.0d0,0.0d0), (0.0d0,0.0d0),
468 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
469 + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.54d0,1.54d0),
470 + (1.54d0,1.54d0), (1.54d0,1.54d0),
471 + (1.54d0,1.54d0), (1.54d0,1.54d0),
472 + (1.54d0,1.54d0), (1.54d0,1.54d0)/
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* .. ZDOTCTEST ..
492 CALL zdotctest(n,cx,incx,cy,incy,ztemp)
493 cdot(1) = ztemp
494 CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
495 ELSE IF (icase.EQ.2) THEN
496* .. ZDOTUTEST ..
497 CALL zdotutest(n,cx,incx,cy,incy,ztemp)
498 cdot(1) = ztemp
499 CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
500 ELSE IF (icase.EQ.3) THEN
501* .. ZAXPYTEST ..
502 CALL zaxpytest(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* .. ZCOPYTEST ..
506 CALL zcopytest(n,cx,incx,cy,incy)
507 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
508 ELSE IF (icase.EQ.5) THEN
509* .. ZSWAPTEST ..
510 CALL zswaptest(n,cx,incx,cy,incy)
511 CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0d0)
512 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
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 DOUBLE PRECISION SFAC
536 INTEGER LEN
537* .. Array Arguments ..
538 DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
539* .. Scalars in Common ..
540 INTEGER ICASE, INCX, INCY, MODE, N
541 LOGICAL PASS
542* .. Local Scalars ..
543 DOUBLE PRECISION SD
544 INTEGER I
545* .. External Functions ..
546 DOUBLE PRECISION 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.0d0)
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*
57199999 FORMAT (' FAIL')
57299998 FORMAT (/' CASE N INCX INCY MODE I ',
573 + ' COMP(I) TRUE(I) DIFFERENCE',
574 + ' SIZE(I)',/1x)
57599997 FORMAT (1x,i4,i3,3i5,i3,2d36.8,2d12.4)
576 END
577 SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
578* ************************* STEST1 *****************************
579*
580* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE 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 DOUBLE PRECISION SCOMP1, SFAC, STRUE1
588* .. Array Arguments ..
589 DOUBLE PRECISION SSIZE(*)
590* .. Local Arrays ..
591 DOUBLE PRECISION 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 DOUBLE PRECISION FUNCTION sdiff(SA,SB)
603* ********************************* SDIFF **************************
604* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
605*
606* .. Scalar Arguments ..
607 DOUBLE PRECISION 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 DOUBLE PRECISION SFAC
619 INTEGER LEN
620* .. Array Arguments ..
621 COMPLEX*16 CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
622* .. Local Scalars ..
623 INTEGER I
624* .. Local Arrays ..
625 DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20)
626* .. External Subroutines ..
627 EXTERNAL stest
628* .. Intrinsic Functions ..
629 INTRINSIC dimag, dble
630* .. Executable Statements ..
631 DO 20 i = 1, len
632 scomp(2*i-1) = dble(ccomp(i))
633 scomp(2*i) = dimag(ccomp(i))
634 strue(2*i-1) = dble(ctrue(i))
635 strue(2*i) = dimag(ctrue(i))
636 ssize(2*i-1) = dble(csize(i))
637 ssize(2*i) = dimag(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*
67799999 FORMAT (' FAIL')
67899998 FORMAT (/' CASE N INCX INCY MODE ',
679 + ' COMP TRUE DIFFERENCE',
680 + /1x)
68199997 FORMAT (1x,i4,i3,3i5,2i36,i12)
682 END
zcblat1
program zcblat1
Definition c_zblat1.f:1
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition cblat1.f:614
ctest
subroutine ctest(len, ccomp, ctrue, csize, sfac)
Definition cblat1.f:714
stest1
subroutine stest1(scomp1, strue1, ssize, sfac)
Definition cblat1.f:673
itest1
subroutine itest1(icomp, itrue)
Definition cblat1.f:748
header
subroutine header
Definition cblat1.f:91
sdiff
real function sdiff(sa, sb)
Definition cblat1.f:701
check2
subroutine check2(sfac)
Definition cblat1.f:348
check1
subroutine check1(sfac)
Definition cblat1.f:122