LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
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 DOUBLE PRECISION THRESH
125 parameter(nout=6, thresh=10.0d0)
126* .. Scalar Arguments ..
127 DOUBLE PRECISION SFAC
128* .. Scalars in Common ..
129 INTEGER ICASE, INCX, INCY, MODE, N
130 LOGICAL PASS
131* .. Local Scalars ..
132 COMPLEX*16 CA
133 DOUBLE PRECISION SA
134 INTEGER I, IX, J, LEN, NP1
135* .. Local Arrays ..
136 COMPLEX*16 CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CVR(8),
137 + CX(8), CXR(15), MWPCS(5), MWPCT(5)
138 DOUBLE PRECISION STRUE2(5), STRUE4(5)
139 INTEGER ITRUE3(5), ITRUEC(5)
140* .. External Functions ..
141 DOUBLE PRECISION DZASUM, DZNRM2
142 INTEGER IZAMAX
143 EXTERNAL dzasum, dznrm2, izamax
144* .. External Subroutines ..
145 EXTERNAL zb1nrm2, zscal, zdscal, ctest, itest1, stest1
146* .. Intrinsic Functions ..
147 INTRINSIC max
148* .. Common blocks ..
149 COMMON /combla/icase, n, incx, incy, mode, pass
150* .. Data statements ..
151 DATA sa, ca/0.3d0, (0.4d0,-0.7d0)/
152 DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
153 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
154 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
155 + (1.0d0,2.0d0), (0.3d0,-0.4d0), (3.0d0,4.0d0),
156 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
157 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
158 + (0.1d0,-0.3d0), (0.5d0,-0.1d0), (5.0d0,6.0d0),
159 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
160 + (5.0d0,6.0d0), (5.0d0,6.0d0), (0.1d0,0.1d0),
161 + (-0.6d0,0.1d0), (0.1d0,-0.3d0), (7.0d0,8.0d0),
162 + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
163 + (7.0d0,8.0d0), (0.3d0,0.1d0), (0.5d0,0.0d0),
164 + (0.0d0,0.5d0), (0.0d0,0.2d0), (2.0d0,3.0d0),
165 + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
166 DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
167 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
168 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
169 + (4.0d0,5.0d0), (0.3d0,-0.4d0), (6.0d0,7.0d0),
170 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
171 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
172 + (0.1d0,-0.3d0), (8.0d0,9.0d0), (0.5d0,-0.1d0),
173 + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
174 + (2.0d0,5.0d0), (2.0d0,5.0d0), (0.1d0,0.1d0),
175 + (3.0d0,6.0d0), (-0.6d0,0.1d0), (4.0d0,7.0d0),
176 + (0.1d0,-0.3d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
177 + (7.0d0,2.0d0), (0.3d0,0.1d0), (5.0d0,8.0d0),
178 + (0.5d0,0.0d0), (6.0d0,9.0d0), (0.0d0,0.5d0),
179 + (8.0d0,3.0d0), (0.0d0,0.2d0), (9.0d0,4.0d0)/
180 DATA cvr/(8.0d0,8.0d0), (-7.0d0,-7.0d0),
181 + (9.0d0,9.0d0), (5.0d0,5.0d0), (9.0d0,9.0d0),
182 + (8.0d0,8.0d0), (7.0d0,7.0d0), (7.0d0,7.0d0)/
183 DATA strue2/0.0d0, 0.5d0, 0.6d0, 0.7d0, 0.8d0/
184 DATA strue4/0.0d0, 0.7d0, 1.0d0, 1.3d0, 1.6d0/
185 DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
186 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
187 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
188 + (1.0d0,2.0d0), (-0.16d0,-0.37d0), (3.0d0,4.0d0),
189 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
190 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
191 + (-0.17d0,-0.19d0), (0.13d0,-0.39d0),
192 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
193 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
194 + (0.11d0,-0.03d0), (-0.17d0,0.46d0),
195 + (-0.17d0,-0.19d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
196 + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
197 + (0.19d0,-0.17d0), (0.20d0,-0.35d0),
198 + (0.35d0,0.20d0), (0.14d0,0.08d0),
199 + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0),
200 + (2.0d0,3.0d0)/
201 DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
202 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
203 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
204 + (4.0d0,5.0d0), (-0.16d0,-0.37d0), (6.0d0,7.0d0),
205 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
206 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
207 + (-0.17d0,-0.19d0), (8.0d0,9.0d0),
208 + (0.13d0,-0.39d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
209 + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
210 + (0.11d0,-0.03d0), (3.0d0,6.0d0),
211 + (-0.17d0,0.46d0), (4.0d0,7.0d0),
212 + (-0.17d0,-0.19d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
213 + (7.0d0,2.0d0), (0.19d0,-0.17d0), (5.0d0,8.0d0),
214 + (0.20d0,-0.35d0), (6.0d0,9.0d0),
215 + (0.35d0,0.20d0), (8.0d0,3.0d0),
216 + (0.14d0,0.08d0), (9.0d0,4.0d0)/
217 DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
218 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
219 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
220 + (1.0d0,2.0d0), (0.09d0,-0.12d0), (3.0d0,4.0d0),
221 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
222 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
223 + (0.03d0,-0.09d0), (0.15d0,-0.03d0),
224 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
225 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
226 + (0.03d0,0.03d0), (-0.18d0,0.03d0),
227 + (0.03d0,-0.09d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
228 + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
229 + (0.09d0,0.03d0), (0.15d0,0.00d0),
230 + (0.00d0,0.15d0), (0.00d0,0.06d0), (2.0d0,3.0d0),
231 + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
232 DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
233 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
234 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
235 + (4.0d0,5.0d0), (0.09d0,-0.12d0), (6.0d0,7.0d0),
236 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
237 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
238 + (0.03d0,-0.09d0), (8.0d0,9.0d0),
239 + (0.15d0,-0.03d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
240 + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
241 + (0.03d0,0.03d0), (3.0d0,6.0d0),
242 + (-0.18d0,0.03d0), (4.0d0,7.0d0),
243 + (0.03d0,-0.09d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
244 + (7.0d0,2.0d0), (0.09d0,0.03d0), (5.0d0,8.0d0),
245 + (0.15d0,0.00d0), (6.0d0,9.0d0), (0.00d0,0.15d0),
246 + (8.0d0,3.0d0), (0.00d0,0.06d0), (9.0d0,4.0d0)/
247 DATA itrue3/0, 1, 2, 2, 2/
248 DATA itruec/0, 1, 1, 1, 1/
249* .. Executable Statements ..
250 DO 60 incx = 1, 2
251 DO 40 np1 = 1, 5
252 n = np1 - 1
253 len = 2*max(n,1)
254* .. Set vector arguments ..
255 DO 20 i = 1, len
256 cx(i) = cv(i,np1,incx)
257 20 CONTINUE
258 IF (icase.EQ.6) THEN
259* .. DZNRM2 ..
260* Test scaling when some entries are tiny or huge
261 CALL zb1nrm2(n,(incx-2)*2,thresh)
262 CALL zb1nrm2(n,incx,thresh)
263* Test with hardcoded mid range entries
264 CALL stest1(dznrm2(n,cx,incx),strue2(np1),strue2(np1),
265 + sfac)
266 ELSE IF (icase.EQ.7) THEN
267* .. DZASUM ..
268 CALL stest1(dzasum(n,cx,incx),strue4(np1),strue4(np1),
269 + sfac)
270 ELSE IF (icase.EQ.8) THEN
271* .. ZSCAL ..
272 CALL zscal(n,ca,cx,incx)
273 CALL ctest(len,cx,ctrue5(1,np1,incx),ctrue5(1,np1,incx),
274 + sfac)
275 ELSE IF (icase.EQ.9) THEN
276* .. ZDSCAL ..
277 CALL zdscal(n,sa,cx,incx)
278 CALL ctest(len,cx,ctrue6(1,np1,incx),ctrue6(1,np1,incx),
279 + sfac)
280 ELSE IF (icase.EQ.10) THEN
281* .. IZAMAX ..
282 CALL itest1(izamax(n,cx,incx),itrue3(np1))
283 DO 160 i = 1, len
284 cx(i) = (42.0d0,43.0d0)
285 160 CONTINUE
286 CALL itest1(izamax(n,cx,incx),itruec(np1))
287 ELSE
288 WRITE (nout,*) ' Shouldn''t be here in CHECK1'
289 stop
290 END IF
291*
292 40 CONTINUE
293 IF (icase.EQ.10) THEN
294 n = 8
295 ix = 1
296 DO 180 i = 1, n
297 cxr(ix) = cvr(i)
298 ix = ix + incx
299 180 CONTINUE
300 CALL itest1(izamax(n,cxr,incx),3)
301 END IF
302 60 CONTINUE
303*
304 incx = 1
305 IF (icase.EQ.8) THEN
306* ZSCAL
307* Add a test for alpha equal to zero.
308 ca = (0.0d0,0.0d0)
309 DO 80 i = 1, 5
310 mwpct(i) = (0.0d0,0.0d0)
311 mwpcs(i) = (1.0d0,1.0d0)
312 80 CONTINUE
313 CALL zscal(5,ca,cx,incx)
314 CALL ctest(5,cx,mwpct,mwpcs,sfac)
315 ELSE IF (icase.EQ.9) THEN
316* ZDSCAL
317* Add a test for alpha equal to zero.
318 sa = 0.0d0
319 DO 100 i = 1, 5
320 mwpct(i) = (0.0d0,0.0d0)
321 mwpcs(i) = (1.0d0,1.0d0)
322 100 CONTINUE
323 CALL zdscal(5,sa,cx,incx)
324 CALL ctest(5,cx,mwpct,mwpcs,sfac)
325* Add a test for alpha equal to one.
326 sa = 1.0d0
327 DO 120 i = 1, 5
328 mwpct(i) = cx(i)
329 mwpcs(i) = cx(i)
330 120 CONTINUE
331 CALL zdscal(5,sa,cx,incx)
332 CALL ctest(5,cx,mwpct,mwpcs,sfac)
333* Add a test for alpha equal to minus one.
334 sa = -1.0d0
335 DO 140 i = 1, 5
336 mwpct(i) = -cx(i)
337 mwpcs(i) = -cx(i)
338 140 CONTINUE
339 CALL zdscal(5,sa,cx,incx)
340 CALL ctest(5,cx,mwpct,mwpcs,sfac)
341 END IF
342 RETURN
343*
344* End of CHECK1
345*
346 END
347 SUBROUTINE check2(SFAC)
348* .. Parameters ..
349 INTEGER NOUT
350 parameter(nout=6)
351* .. Scalar Arguments ..
352 DOUBLE PRECISION SFAC
353* .. Scalars in Common ..
354 INTEGER ICASE, INCX, INCY, MODE, N
355 LOGICAL PASS
356* .. Local Scalars ..
357 COMPLEX*16 CA
358 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
359 + MX, MY
360* .. Local Arrays ..
361 COMPLEX*16 CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
362 + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
363 + CT8(7,4,4), CTY0(1), CX(7), CX0(1), CX1(7),
364 + CY(7), CY0(1), CY1(7)
365 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
366* .. External Functions ..
367 COMPLEX*16 ZDOTC, ZDOTU
368 EXTERNAL zdotc, zdotu
369* .. External Subroutines ..
370 EXTERNAL zaxpy, zcopy, zswap, ctest
371* .. Intrinsic Functions ..
372 INTRINSIC abs, min
373* .. Common blocks ..
374 COMMON /combla/icase, n, incx, incy, mode, pass
375* .. Data statements ..
376 DATA ca/(0.4d0,-0.7d0)/
377 DATA incxs/1, 2, -2, -1/
378 DATA incys/1, -2, 1, -2/
379 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
380 DATA ns/0, 1, 2, 4/
381 DATA cx1/(0.7d0,-0.8d0), (-0.4d0,-0.7d0),
382 + (-0.1d0,-0.9d0), (0.2d0,-0.8d0),
383 + (-0.9d0,-0.4d0), (0.1d0,0.4d0), (-0.6d0,0.6d0)/
384 DATA cy1/(0.6d0,-0.6d0), (-0.9d0,0.5d0),
385 + (0.7d0,-0.6d0), (0.1d0,-0.5d0), (-0.1d0,-0.2d0),
386 + (-0.5d0,-0.3d0), (0.8d0,-0.7d0)/
387 DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
388 + (0.0d0,0.0d0), (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), (0.0d0,0.0d0), (0.0d0,0.0d0),
391 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
392 + (0.0d0,0.0d0), (0.32d0,-1.41d0),
393 + (-1.55d0,0.5d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
394 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
395 + (0.32d0,-1.41d0), (-1.55d0,0.5d0),
396 + (0.03d0,-0.89d0), (-0.38d0,-0.96d0),
397 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
398 DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
399 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
400 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
401 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
402 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
403 + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
404 + (-0.9d0,0.5d0), (0.42d0,-1.41d0), (0.0d0,0.0d0),
405 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
406 + (0.78d0,0.06d0), (-0.9d0,0.5d0),
407 + (0.06d0,-0.13d0), (0.1d0,-0.5d0),
408 + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
409 + (0.52d0,-1.51d0)/
410 DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6d0,-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.0d0,0.0d0),
413 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
414 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
415 + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
416 + (-1.18d0,-0.31d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
417 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
418 + (0.78d0,0.06d0), (-1.54d0,0.97d0),
419 + (0.03d0,-0.89d0), (-0.18d0,-1.31d0),
420 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
421 DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
422 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
423 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
424 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
425 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
426 + (0.0d0,0.0d0), (0.32d0,-1.41d0), (-0.9d0,0.5d0),
427 + (0.05d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
428 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.32d0,-1.41d0),
429 + (-0.9d0,0.5d0), (0.05d0,-0.6d0), (0.1d0,-0.5d0),
430 + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
431 + (0.32d0,-1.16d0)/
432 DATA ct7/(0.0d0,0.0d0), (-0.06d0,-0.90d0),
433 + (0.65d0,-0.47d0), (-0.34d0,-1.22d0),
434 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
435 + (-0.59d0,-1.46d0), (-1.04d0,-0.04d0),
436 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
437 + (-0.83d0,0.59d0), (0.07d0,-0.37d0),
438 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
439 + (-0.76d0,-1.15d0), (-1.33d0,-1.82d0)/
440 DATA ct6/(0.0d0,0.0d0), (0.90d0,0.06d0),
441 + (0.91d0,-0.77d0), (1.80d0,-0.10d0),
442 + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.45d0,0.74d0),
443 + (0.20d0,0.90d0), (0.0d0,0.0d0), (0.90d0,0.06d0),
444 + (-0.55d0,0.23d0), (0.83d0,-0.39d0),
445 + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.04d0,0.79d0),
446 + (1.95d0,1.22d0)/
447 DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7d0,-0.8d0),
448 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
449 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
450 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
451 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
452 + (0.0d0,0.0d0), (0.6d0,-0.6d0), (-0.9d0,0.5d0),
453 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
454 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
455 + (-0.9d0,0.5d0), (0.7d0,-0.6d0), (0.1d0,-0.5d0),
456 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
457 DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7d0,-0.8d0),
458 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
459 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
460 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
461 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
462 + (0.0d0,0.0d0), (0.7d0,-0.6d0), (-0.4d0,-0.7d0),
463 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
464 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.8d0,-0.7d0),
465 + (-0.4d0,-0.7d0), (-0.1d0,-0.2d0),
466 + (0.2d0,-0.8d0), (0.7d0,-0.6d0), (0.1d0,0.4d0),
467 + (0.6d0,-0.6d0)/
468 DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7d0,-0.8d0),
469 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
470 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
471 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
472 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
473 + (0.0d0,0.0d0), (-0.9d0,0.5d0), (-0.4d0,-0.7d0),
474 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
475 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.1d0,-0.5d0),
476 + (-0.4d0,-0.7d0), (0.7d0,-0.6d0), (0.2d0,-0.8d0),
477 + (-0.9d0,0.5d0), (0.1d0,0.4d0), (0.6d0,-0.6d0)/
478 DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7d0,-0.8d0),
479 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
480 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
481 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
482 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
483 + (0.0d0,0.0d0), (0.6d0,-0.6d0), (0.7d0,-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.6d0,-0.6d0),
486 + (0.7d0,-0.6d0), (-0.1d0,-0.2d0), (0.8d0,-0.7d0),
487 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
488 DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
489 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
490 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
491 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
492 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
493 + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.4d0,-0.7d0),
494 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
495 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
496 + (-0.4d0,-0.7d0), (-0.1d0,-0.9d0),
497 + (0.2d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
498 + (0.0d0,0.0d0)/
499 DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
500 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
501 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
502 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
503 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
504 + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (-0.9d0,0.5d0),
505 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
506 + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
507 + (-0.9d0,0.5d0), (-0.9d0,-0.4d0), (0.1d0,-0.5d0),
508 + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
509 + (0.7d0,-0.8d0)/
510 DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
511 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
512 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
513 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
514 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
515 + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (0.7d0,-0.8d0),
516 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
517 + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
518 + (-0.9d0,-0.4d0), (-0.1d0,-0.9d0),
519 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
520 + (0.0d0,0.0d0)/
521 DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
522 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
523 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
524 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
525 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
526 + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.9d0,0.5d0),
527 + (-0.4d0,-0.7d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
528 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
529 + (-0.9d0,0.5d0), (-0.4d0,-0.7d0), (0.1d0,-0.5d0),
530 + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
531 + (0.2d0,-0.8d0)/
532 DATA csize1/(0.0d0,0.0d0), (0.9d0,0.9d0),
533 + (1.63d0,1.73d0), (2.90d0,2.78d0)/
534 DATA csize3/(0.0d0,0.0d0), (0.0d0,0.0d0),
535 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
536 + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.17d0,1.17d0),
537 + (1.17d0,1.17d0), (1.17d0,1.17d0),
538 + (1.17d0,1.17d0), (1.17d0,1.17d0),
539 + (1.17d0,1.17d0), (1.17d0,1.17d0)/
540 DATA csize2/(0.0d0,0.0d0), (0.0d0,0.0d0),
541 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
542 + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.54d0,1.54d0),
543 + (1.54d0,1.54d0), (1.54d0,1.54d0),
544 + (1.54d0,1.54d0), (1.54d0,1.54d0),
545 + (1.54d0,1.54d0), (1.54d0,1.54d0)/
546* .. Executable Statements ..
547 DO 60 ki = 1, 4
548 incx = incxs(ki)
549 incy = incys(ki)
550 mx = abs(incx)
551 my = abs(incy)
552*
553 DO 40 kn = 1, 4
554 n = ns(kn)
555 ksize = min(2,kn)
556 lenx = lens(kn,mx)
557 leny = lens(kn,my)
558* .. initialize all argument arrays ..
559 DO 20 i = 1, 7
560 cx(i) = cx1(i)
561 cy(i) = cy1(i)
562 20 CONTINUE
563 IF (icase.EQ.1) THEN
564* .. ZDOTC ..
565 cdot(1) = zdotc(n,cx,incx,cy,incy)
566 CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
567 ELSE IF (icase.EQ.2) THEN
568* .. ZDOTU ..
569 cdot(1) = zdotu(n,cx,incx,cy,incy)
570 CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
571 ELSE IF (icase.EQ.3) THEN
572* .. ZAXPY ..
573 CALL zaxpy(n,ca,cx,incx,cy,incy)
574 CALL ctest(leny,cy,ct8(1,kn,ki),csize2(1,ksize),sfac)
575 ELSE IF (icase.EQ.4) THEN
576* .. ZCOPY ..
577 CALL zcopy(n,cx,incx,cy,incy)
578 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
579 IF (ki.EQ.1) THEN
580 cx0(1) = (42.0d0,43.0d0)
581 cy0(1) = (44.0d0,45.0d0)
582 IF (n.EQ.0) THEN
583 cty0(1) = cy0(1)
584 ELSE
585 cty0(1) = cx0(1)
586 END IF
587 lincx = incx
588 incx = 0
589 lincy = incy
590 incy = 0
591 CALL zcopy(n,cx0,incx,cy0,incy)
592 CALL ctest(1,cy0,cty0,csize3,1.0d0)
593 incx = lincx
594 incy = lincy
595 END IF
596 ELSE IF (icase.EQ.5) THEN
597* .. ZSWAP ..
598 CALL zswap(n,cx,incx,cy,incy)
599 CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0d0)
600 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
601 ELSE
602 WRITE (nout,*) ' Shouldn''t be here in CHECK2'
603 stop
604 END IF
605*
606 40 CONTINUE
607 60 CONTINUE
608 RETURN
609*
610* End of CHECK2
611*
612 END
613 SUBROUTINE stest(LEN,SCOMP,STRUE,SSIZE,SFAC)
614* ********************************* STEST **************************
615*
616* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
617* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
618* NEGLIGIBLE.
619*
620* C. L. LAWSON, JPL, 1974 DEC 10
621*
622* .. Parameters ..
623 INTEGER NOUT
624 DOUBLE PRECISION ZERO
625 parameter(nout=6, zero=0.0d0)
626* .. Scalar Arguments ..
627 DOUBLE PRECISION SFAC
628 INTEGER LEN
629* .. Array Arguments ..
630 DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
631* .. Scalars in Common ..
632 INTEGER ICASE, INCX, INCY, MODE, N
633 LOGICAL PASS
634* .. Local Scalars ..
635 DOUBLE PRECISION SD
636 INTEGER I
637* .. External Functions ..
638 DOUBLE PRECISION SDIFF
639 EXTERNAL sdiff
640* .. Intrinsic Functions ..
641 INTRINSIC abs
642* .. Common blocks ..
643 COMMON /combla/icase, n, incx, incy, mode, pass
644* .. Executable Statements ..
645*
646 DO 40 i = 1, len
647 sd = scomp(i) - strue(i)
648 IF (abs(sfac*sd) .LE. abs(ssize(i))*epsilon(zero))
649 + GO TO 40
650*
651* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
652*
653 IF ( .NOT. pass) GO TO 20
654* PRINT FAIL MESSAGE AND HEADER.
655 pass = .false.
656 WRITE (nout,99999)
657 WRITE (nout,99998)
658 20 WRITE (nout,99997) icase, n, incx, incy, mode, i, scomp(i),
659 + strue(i), sd, ssize(i)
660 40 CONTINUE
661 RETURN
662*
66399999 FORMAT (' FAIL')
66499998 FORMAT (/' CASE N INCX INCY MODE I ',
665 + ' COMP(I) TRUE(I) DIFFERENCE',
666 + ' SIZE(I)',/1x)
66799997 FORMAT (1x,i4,i3,3i5,i3,2d36.8,2d12.4)
668*
669* End of STEST
670*
671 END
672 SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
673* ************************* STEST1 *****************************
674*
675* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
676* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
677* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
678*
679* C.L. LAWSON, JPL, 1978 DEC 6
680*
681* .. Scalar Arguments ..
682 DOUBLE PRECISION SCOMP1, SFAC, STRUE1
683* .. Array Arguments ..
684 DOUBLE PRECISION SSIZE(*)
685* .. Local Arrays ..
686 DOUBLE PRECISION SCOMP(1), STRUE(1)
687* .. External Subroutines ..
688 EXTERNAL stest
689* .. Executable Statements ..
690*
691 scomp(1) = scomp1
692 strue(1) = strue1
693 CALL stest(1,scomp,strue,ssize,sfac)
694*
695 RETURN
696*
697* End of STEST1
698*
699 END
700 DOUBLE PRECISION FUNCTION sdiff(SA,SB)
701* ********************************* SDIFF **************************
702* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
703*
704* .. Scalar Arguments ..
705 DOUBLE PRECISION sa, sb
706* .. Executable Statements ..
707 sdiff = sa - sb
708 RETURN
709*
710* End of SDIFF
711*
712 END
713 SUBROUTINE ctest(LEN,CCOMP,CTRUE,CSIZE,SFAC)
714* **************************** CTEST *****************************
715*
716* C.L. LAWSON, JPL, 1978 DEC 6
717*
718* .. Scalar Arguments ..
719 DOUBLE PRECISION SFAC
720 INTEGER LEN
721* .. Array Arguments ..
722 COMPLEX*16 CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
723* .. Local Scalars ..
724 INTEGER I
725* .. Local Arrays ..
726 DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20)
727* .. External Subroutines ..
728 EXTERNAL stest
729* .. Intrinsic Functions ..
730 INTRINSIC dimag, dble
731* .. Executable Statements ..
732 DO 20 i = 1, len
733 scomp(2*i-1) = dble(ccomp(i))
734 scomp(2*i) = dimag(ccomp(i))
735 strue(2*i-1) = dble(ctrue(i))
736 strue(2*i) = dimag(ctrue(i))
737 ssize(2*i-1) = dble(csize(i))
738 ssize(2*i) = dimag(csize(i))
739 20 CONTINUE
740*
741 CALL stest(2*len,scomp,strue,ssize,sfac)
742 RETURN
743*
744* End of CTEST
745*
746 END
747 SUBROUTINE itest1(ICOMP,ITRUE)
748* ********************************* ITEST1 *************************
749*
750* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
751* EQUALITY.
752* C. L. LAWSON, JPL, 1974 DEC 10
753*
754* .. Parameters ..
755 INTEGER NOUT
756 parameter(nout=6)
757* .. Scalar Arguments ..
758 INTEGER ICOMP, ITRUE
759* .. Scalars in Common ..
760 INTEGER ICASE, INCX, INCY, MODE, N
761 LOGICAL PASS
762* .. Local Scalars ..
763 INTEGER ID
764* .. Common blocks ..
765 COMMON /combla/icase, n, incx, incy, mode, pass
766* .. Executable Statements ..
767 IF (icomp.EQ.itrue) GO TO 40
768*
769* HERE ICOMP IS NOT EQUAL TO ITRUE.
770*
771 IF ( .NOT. pass) GO TO 20
772* PRINT FAIL MESSAGE AND HEADER.
773 pass = .false.
774 WRITE (nout,99999)
775 WRITE (nout,99998)
776 20 id = icomp - itrue
777 WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
778 40 CONTINUE
779 RETURN
780*
78199999 FORMAT (' FAIL')
78299998 FORMAT (/' CASE N INCX INCY MODE ',
783 + ' COMP TRUE DIFFERENCE',
784 + /1x)
78599997 FORMAT (1x,i4,i3,3i5,2i36,i12)
786*
787* End of ITEST1
788*
789 END
790 SUBROUTINE zb1nrm2(N,INCX,THRESH)
791* Compare NRM2 with a reference computation using combinations
792* of the following values:
793*
794* 0, very small, small, ulp, 1, 1/ulp, big, very big, infinity, NaN
795*
796* one of these values is used to initialize x(1) and x(2:N) is
797* filled with random values from [-1,1] scaled by another of
798* these values.
799*
800* This routine is adapted from the test suite provided by
801* Anderson E. (2017)
802* Algorithm 978: Safe Scaling in the Level 1 BLAS
803* ACM Trans Math Softw 44:1--28
804* https://doi.org/10.1145/3061665
805*
806* .. Scalar Arguments ..
807 INTEGER INCX, N
808 DOUBLE PRECISION THRESH
809*
810* =====================================================================
811* .. Parameters ..
812 INTEGER NMAX, NOUT, NV
813 parameter(nmax=20, nout=6, nv=10)
814 DOUBLE PRECISION HALF, ONE, THREE, TWO, ZERO
815 parameter(half=0.5d+0, one=1.0d+0, two= 2.0d+0,
816 & three=3.0d+0, zero=0.0d+0)
817* .. External Functions ..
818 DOUBLE PRECISION DZNRM2
819 EXTERNAL dznrm2
820* .. Intrinsic Functions ..
821 INTRINSIC aimag, abs, dcmplx, dble, max, min, sqrt
822* .. Model parameters ..
823 DOUBLE PRECISION BIGNUM, SAFMAX, SAFMIN, SMLNUM, ULP
824 parameter(bignum=0.99792015476735990583d+292,
825 & safmax=0.44942328371557897693d+308,
826 & safmin=0.22250738585072013831d-307,
827 & smlnum=0.10020841800044863890d-291,
828 & ulp=0.22204460492503130808d-015)
829* .. Local Scalars ..
830 COMPLEX*16 ROGUE
831 DOUBLE PRECISION SNRM, TRAT, V0, V1, WORKSSQ, Y1, Y2,
832 & YMAX, YMIN, YNRM, ZNRM
833 INTEGER I, IV, IW, IX, KS
834 LOGICAL FIRST
835* .. Local Arrays ..
836 COMPLEX*16 X(NMAX), Z(NMAX)
837 DOUBLE PRECISION VALUES(NV), WORK(NMAX)
838* .. Executable Statements ..
839 values(1) = zero
840 values(2) = two*safmin
841 values(3) = smlnum
842 values(4) = ulp
843 values(5) = one
844 values(6) = one / ulp
845 values(7) = bignum
846 values(8) = safmax
847 values(9) = dxvals(v0,2)
848 values(10) = dxvals(v0,3)
849 rogue = dcmplx(1234.5678d+0,-1234.5678d+0)
850 first = .true.
851*
852* Check that the arrays are large enough
853*
854 IF (n*abs(incx).GT.nmax) THEN
855 WRITE (nout,99) "DZNRM2", nmax, incx, n, n*abs(incx)
856 RETURN
857 END IF
858*
859* Zero-sized inputs are tested in STEST1.
860 IF (n.LE.0) THEN
861 RETURN
862 END IF
863*
864* Generate 2*(N-1) values in (-1,1).
865*
866 ks = 2*(n-1)
867 DO i = 1, ks
868 CALL random_number(work(i))
869 work(i) = one - two*work(i)
870 END DO
871*
872* Compute the sum of squares of the random values
873* by an unscaled algorithm.
874*
875 workssq = zero
876 DO i = 1, ks
877 workssq = workssq + work(i)*work(i)
878 END DO
879*
880* Construct the test vector with one known value
881* and the rest from the random work array multiplied
882* by a scaling factor.
883*
884 DO iv = 1, nv
885 v0 = values(iv)
886 IF (abs(v0).GT.one) THEN
887 v0 = v0*half*half
888 END IF
889 z(1) = dcmplx(v0,-three*v0)
890 DO iw = 1, nv
891 v1 = values(iw)
892 IF (abs(v1).GT.one) THEN
893 v1 = (v1*half) / sqrt(dble(ks+1))
894 END IF
895 DO i = 1, n-1
896 z(i+1) = dcmplx(v1*work(2*i-1),v1*work(2*i))
897 END DO
898*
899* Compute the expected value of the 2-norm
900*
901 y1 = abs(v0) * sqrt(10.0d0)
902 IF (n.GT.1) THEN
903 y2 = abs(v1)*sqrt(workssq)
904 ELSE
905 y2 = zero
906 END IF
907 ymin = min(y1, y2)
908 ymax = max(y1, y2)
909*
910* Expected value is NaN if either is NaN. The test
911* for YMIN == YMAX avoids further computation if both
912* are infinity.
913*
914 IF ((y1.NE.y1).OR.(y2.NE.y2)) THEN
915* add to propagate NaN
916 ynrm = y1 + y2
917 ELSE IF (ymin == ymax) THEN
918 ynrm = sqrt(two)*ymax
919 ELSE IF (ymax == zero) THEN
920 ynrm = zero
921 ELSE
922 ynrm = ymax*sqrt(one + (ymin / ymax)**2)
923 END IF
924*
925* Fill the input array to DZNRM2 with steps of incx
926*
927 DO i = 1, n
928 x(i) = rogue
929 END DO
930 ix = 1
931 IF (incx.LT.0) ix = 1 - (n-1)*incx
932 DO i = 1, n
933 x(ix) = z(i)
934 ix = ix + incx
935 END DO
936*
937* Call DZNRM2 to compute the 2-norm
938*
939 snrm = dznrm2(n,x,incx)
940*
941* Compare SNRM and ZNRM. Roundoff error grows like O(n)
942* in this implementation so we scale the test ratio accordingly.
943*
944 IF (incx.EQ.0) THEN
945 y1 = abs(dble(x(1)))
946 y2 = abs(aimag(x(1)))
947 ymin = min(y1, y2)
948 ymax = max(y1, y2)
949 IF ((y1.NE.y1).OR.(y2.NE.y2)) THEN
950* add to propagate NaN
951 znrm = y1 + y2
952 ELSE IF (ymin == ymax) THEN
953 znrm = sqrt(two)*ymax
954 ELSE IF (ymax == zero) THEN
955 znrm = zero
956 ELSE
957 znrm = ymax * sqrt(one + (ymin / ymax)**2)
958 END IF
959 znrm = sqrt(dble(n)) * znrm
960 ELSE
961 znrm = ynrm
962 END IF
963*
964* The tests for NaN rely on the compiler not being overly
965* aggressive and removing the statements altogether.
966 IF ((snrm.NE.snrm).OR.(znrm.NE.znrm)) THEN
967 IF ((snrm.NE.snrm).NEQV.(znrm.NE.znrm)) THEN
968 trat = one / ulp
969 ELSE
970 trat = zero
971 END IF
972 ELSE IF (znrm == zero) THEN
973 trat = snrm / ulp
974 ELSE
975 trat = (abs(snrm-znrm) / znrm) / (two*dble(n)*ulp)
976 END IF
977 IF ((trat.NE.trat).OR.(trat.GE.thresh)) THEN
978 IF (first) THEN
979 first = .false.
980 WRITE(nout,99999)
981 END IF
982 WRITE (nout,98) "DZNRM2", n, incx, iv, iw, trat
983 END IF
984 END DO
985 END DO
98699999 FORMAT (' FAIL')
987 99 FORMAT ( ' Not enough space to test ', a6, ': NMAX = ',i6,
988 + ', INCX = ',i6,/,' N = ',i6,', must be at least ',i6 )
989 98 FORMAT( 1x, a6, ': N=', i6,', INCX=', i4, ', IV=', i2, ', IW=',
990 + i2, ', test=', e15.8 )
991 RETURN
992 CONTAINS
993 DOUBLE PRECISION FUNCTION dxvals(XX,K)
994* .. Scalar Arguments ..
995 DOUBLE PRECISION XX
996 INTEGER K
997* .. Parameters ..
998 DOUBLE PRECISION ZERO
999 parameter(zero=0.0d+0)
1000* .. Local Scalars ..
1001 DOUBLE PRECISION X, Y, Z
1002* .. Intrinsic Functions ..
1003 INTRINSIC huge
1004* .. Executable Statements ..
1005 x = zero
1006 y = huge(xx)
1007 z = y*y
1008 IF (k.EQ.1) THEN
1009 x = -z
1010 ELSE IF (k.EQ.2) THEN
1011 x = z
1012 ELSE IF (k.EQ.3) THEN
1013 x = z / z
1014 END IF
1015 dxvals = x
1016 RETURN
1017 END
1018 END
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
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zdscal
subroutine zdscal(n, da, zx, incx)
ZDSCAL
Definition zdscal.f:78
zscal
subroutine zscal(n, za, zx, incx)
ZSCAL
Definition zscal.f:78
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
zb1nrm2
subroutine zb1nrm2(n, incx, thresh)
Definition zblat1.f:791
zblat1
program zblat1
ZBLAT1
Definition zblat1.f:36