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