LAPACK 3.12.1
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
cblat1.f
Go to the documentation of this file.
1*> \brief \b CBLAT1
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 CBLAT1
12*
13*
14*> \par Purpose:
15* =============
16*>
17*> \verbatim
18*>
19*> Test program for the COMPLEX Level 1 BLAS.
20*> Based upon the original BLAS test routine together with:
21*>
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 complex_blas_testing
34*
35* =====================================================================
36 PROGRAM cblat1
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 REAL 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.765625e-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 CBLAT1
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)/'CDOTC '/
103 DATA l(2)/'CDOTU '/
104 DATA l(3)/'CAXPY '/
105 DATA l(4)/'CCOPY '/
106 DATA l(5)/'CSWAP '/
107 DATA l(6)/'SCNRM2'/
108 DATA l(7)/'SCASUM'/
109 DATA l(8)/'CSCAL '/
110 DATA l(9)/'CSSCAL'/
111 DATA l(10)/'ICAMAX'/
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 REAL THRESH
125 parameter(nout=6, thresh=10.0e0)
126* .. Scalar Arguments ..
127 REAL SFAC
128* .. Scalars in Common ..
129 INTEGER ICASE, INCX, INCY, MODE, N
130 LOGICAL PASS
131* .. Local Scalars ..
132 COMPLEX CA
133 REAL SA
134 INTEGER I, IX, J, LEN, NP1
135* .. Local Arrays ..
136 COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CVR(8),
137 + CX(8), CXR(15), MWPCS(5), MWPCT(5)
138 REAL STRUE2(5), STRUE4(5)
139 INTEGER ITRUE3(5), ITRUEC(5)
140* .. External Functions ..
141 REAL SCASUM, SCNRM2
142 INTEGER ICAMAX
143 EXTERNAL scasum, scnrm2, icamax
144* .. External Subroutines ..
145 EXTERNAL cb1nrm2, cscal, csscal, 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.3e0, (0.4e0,-0.7e0)/
152 DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
153 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
154 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
155 + (1.0e0,2.0e0), (0.3e0,-0.4e0), (3.0e0,4.0e0),
156 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
157 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
158 + (0.1e0,-0.3e0), (0.5e0,-0.1e0), (5.0e0,6.0e0),
159 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
160 + (5.0e0,6.0e0), (5.0e0,6.0e0), (0.1e0,0.1e0),
161 + (-0.6e0,0.1e0), (0.1e0,-0.3e0), (7.0e0,8.0e0),
162 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
163 + (7.0e0,8.0e0), (0.3e0,0.1e0), (0.5e0,0.0e0),
164 + (0.0e0,0.5e0), (0.0e0,0.2e0), (2.0e0,3.0e0),
165 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
166 DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
167 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
168 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
169 + (4.0e0,5.0e0), (0.3e0,-0.4e0), (6.0e0,7.0e0),
170 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
171 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
172 + (0.1e0,-0.3e0), (8.0e0,9.0e0), (0.5e0,-0.1e0),
173 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
174 + (2.0e0,5.0e0), (2.0e0,5.0e0), (0.1e0,0.1e0),
175 + (3.0e0,6.0e0), (-0.6e0,0.1e0), (4.0e0,7.0e0),
176 + (0.1e0,-0.3e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
177 + (7.0e0,2.0e0), (0.3e0,0.1e0), (5.0e0,8.0e0),
178 + (0.5e0,0.0e0), (6.0e0,9.0e0), (0.0e0,0.5e0),
179 + (8.0e0,3.0e0), (0.0e0,0.2e0), (9.0e0,4.0e0)/
180 DATA cvr/(8.0e0,8.0e0), (-7.0e0,-7.0e0),
181 + (9.0e0,9.0e0), (5.0e0,5.0e0), (9.0e0,9.0e0),
182 + (8.0e0,8.0e0), (7.0e0,7.0e0), (7.0e0,7.0e0)/
183 DATA strue2/0.0e0, 0.5e0, 0.6e0, 0.7e0, 0.8e0/
184 DATA strue4/0.0e0, 0.7e0, 1.0e0, 1.3e0, 1.6e0/
185 DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
186 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
187 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
188 + (1.0e0,2.0e0), (-0.16e0,-0.37e0), (3.0e0,4.0e0),
189 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
190 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
191 + (-0.17e0,-0.19e0), (0.13e0,-0.39e0),
192 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
193 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
194 + (0.11e0,-0.03e0), (-0.17e0,0.46e0),
195 + (-0.17e0,-0.19e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
196 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
197 + (0.19e0,-0.17e0), (0.20e0,-0.35e0),
198 + (0.35e0,0.20e0), (0.14e0,0.08e0),
199 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0),
200 + (2.0e0,3.0e0)/
201 DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
202 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
203 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
204 + (4.0e0,5.0e0), (-0.16e0,-0.37e0), (6.0e0,7.0e0),
205 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
206 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
207 + (-0.17e0,-0.19e0), (8.0e0,9.0e0),
208 + (0.13e0,-0.39e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
209 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
210 + (0.11e0,-0.03e0), (3.0e0,6.0e0),
211 + (-0.17e0,0.46e0), (4.0e0,7.0e0),
212 + (-0.17e0,-0.19e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
213 + (7.0e0,2.0e0), (0.19e0,-0.17e0), (5.0e0,8.0e0),
214 + (0.20e0,-0.35e0), (6.0e0,9.0e0),
215 + (0.35e0,0.20e0), (8.0e0,3.0e0),
216 + (0.14e0,0.08e0), (9.0e0,4.0e0)/
217 DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
218 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
219 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
220 + (1.0e0,2.0e0), (0.09e0,-0.12e0), (3.0e0,4.0e0),
221 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
222 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
223 + (0.03e0,-0.09e0), (0.15e0,-0.03e0),
224 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
225 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
226 + (0.03e0,0.03e0), (-0.18e0,0.03e0),
227 + (0.03e0,-0.09e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
228 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
229 + (0.09e0,0.03e0), (0.15e0,0.00e0),
230 + (0.00e0,0.15e0), (0.00e0,0.06e0), (2.0e0,3.0e0),
231 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
232 DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
233 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
234 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
235 + (4.0e0,5.0e0), (0.09e0,-0.12e0), (6.0e0,7.0e0),
236 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
237 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
238 + (0.03e0,-0.09e0), (8.0e0,9.0e0),
239 + (0.15e0,-0.03e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
240 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
241 + (0.03e0,0.03e0), (3.0e0,6.0e0),
242 + (-0.18e0,0.03e0), (4.0e0,7.0e0),
243 + (0.03e0,-0.09e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
244 + (7.0e0,2.0e0), (0.09e0,0.03e0), (5.0e0,8.0e0),
245 + (0.15e0,0.00e0), (6.0e0,9.0e0), (0.00e0,0.15e0),
246 + (8.0e0,3.0e0), (0.00e0,0.06e0), (9.0e0,4.0e0)/
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* .. SCNRM2 ..
260* Test scaling when some entries are tiny or huge
261 CALL cb1nrm2(n,(incx-2)*2,thresh)
262 CALL cb1nrm2(n,incx,thresh)
263* Test with hardcoded mid range entries
264 CALL stest1(scnrm2(n,cx,incx),strue2(np1),strue2(np1),
265 + sfac)
266 ELSE IF (icase.EQ.7) THEN
267* .. SCASUM ..
268 CALL stest1(scasum(n,cx,incx),strue4(np1),strue4(np1),
269 + sfac)
270 ELSE IF (icase.EQ.8) THEN
271* .. CSCAL ..
272 CALL cscal(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* .. CSSCAL ..
277 CALL csscal(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* .. ICAMAX ..
282 CALL itest1(icamax(n,cx,incx),itrue3(np1))
283 DO 160 i = 1, len
284 cx(i) = (42.0e0,43.0e0)
285 160 CONTINUE
286 CALL itest1(icamax(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(icamax(n,cxr,incx),3)
301 END IF
302 60 CONTINUE
303*
304 incx = 1
305 IF (icase.EQ.8) THEN
306* CSCAL
307* Add a test for alpha equal to zero.
308 ca = (0.0e0,0.0e0)
309 DO 80 i = 1, 5
310 mwpct(i) = (0.0e0,0.0e0)
311 mwpcs(i) = (1.0e0,1.0e0)
312 80 CONTINUE
313 CALL cscal(5,ca,cx,incx)
314 CALL ctest(5,cx,mwpct,mwpcs,sfac)
315 ELSE IF (icase.EQ.9) THEN
316* CSSCAL
317* Add a test for alpha equal to zero.
318 sa = 0.0e0
319 DO 100 i = 1, 5
320 mwpct(i) = (0.0e0,0.0e0)
321 mwpcs(i) = (1.0e0,1.0e0)
322 100 CONTINUE
323 CALL csscal(5,sa,cx,incx)
324 CALL ctest(5,cx,mwpct,mwpcs,sfac)
325* Add a test for alpha equal to one.
326 sa = 1.0e0
327 DO 120 i = 1, 5
328 mwpct(i) = cx(i)
329 mwpcs(i) = cx(i)
330 120 CONTINUE
331 CALL csscal(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.0e0
335 DO 140 i = 1, 5
336 mwpct(i) = -cx(i)
337 mwpcs(i) = -cx(i)
338 140 CONTINUE
339 CALL csscal(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 REAL SFAC
353* .. Scalars in Common ..
354 INTEGER ICASE, INCX, INCY, MODE, N
355 LOGICAL PASS
356* .. Local Scalars ..
357 COMPLEX CA
358 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
359 + MX, MY
360* .. Local Arrays ..
361 COMPLEX 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 CDOTC, CDOTU
368 EXTERNAL cdotc, cdotu
369* .. External Subroutines ..
370 EXTERNAL caxpy, ccopy, cswap, 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.4e0,-0.7e0)/
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.7e0,-0.8e0), (-0.4e0,-0.7e0),
382 + (-0.1e0,-0.9e0), (0.2e0,-0.8e0),
383 + (-0.9e0,-0.4e0), (0.1e0,0.4e0), (-0.6e0,0.6e0)/
384 DATA cy1/(0.6e0,-0.6e0), (-0.9e0,0.5e0),
385 + (0.7e0,-0.6e0), (0.1e0,-0.5e0), (-0.1e0,-0.2e0),
386 + (-0.5e0,-0.3e0), (0.8e0,-0.7e0)/
387 DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
388 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
389 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
390 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
391 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
392 + (0.0e0,0.0e0), (0.32e0,-1.41e0),
393 + (-1.55e0,0.5e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
394 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
395 + (0.32e0,-1.41e0), (-1.55e0,0.5e0),
396 + (0.03e0,-0.89e0), (-0.38e0,-0.96e0),
397 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
398 DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
399 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
400 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
401 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
402 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
403 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
404 + (-0.9e0,0.5e0), (0.42e0,-1.41e0), (0.0e0,0.0e0),
405 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
406 + (0.78e0,0.06e0), (-0.9e0,0.5e0),
407 + (0.06e0,-0.13e0), (0.1e0,-0.5e0),
408 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
409 + (0.52e0,-1.51e0)/
410 DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
411 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
412 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
413 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
414 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
415 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
416 + (-1.18e0,-0.31e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
417 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
418 + (0.78e0,0.06e0), (-1.54e0,0.97e0),
419 + (0.03e0,-0.89e0), (-0.18e0,-1.31e0),
420 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
421 DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
422 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
423 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
424 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
425 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
426 + (0.0e0,0.0e0), (0.32e0,-1.41e0), (-0.9e0,0.5e0),
427 + (0.05e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
428 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.32e0,-1.41e0),
429 + (-0.9e0,0.5e0), (0.05e0,-0.6e0), (0.1e0,-0.5e0),
430 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
431 + (0.32e0,-1.16e0)/
432 DATA ct7/(0.0e0,0.0e0), (-0.06e0,-0.90e0),
433 + (0.65e0,-0.47e0), (-0.34e0,-1.22e0),
434 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
435 + (-0.59e0,-1.46e0), (-1.04e0,-0.04e0),
436 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
437 + (-0.83e0,0.59e0), (0.07e0,-0.37e0),
438 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
439 + (-0.76e0,-1.15e0), (-1.33e0,-1.82e0)/
440 DATA ct6/(0.0e0,0.0e0), (0.90e0,0.06e0),
441 + (0.91e0,-0.77e0), (1.80e0,-0.10e0),
442 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.45e0,0.74e0),
443 + (0.20e0,0.90e0), (0.0e0,0.0e0), (0.90e0,0.06e0),
444 + (-0.55e0,0.23e0), (0.83e0,-0.39e0),
445 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.04e0,0.79e0),
446 + (1.95e0,1.22e0)/
447 DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7e0,-0.8e0),
448 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
449 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
450 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
451 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
452 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (-0.9e0,0.5e0),
453 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
454 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
455 + (-0.9e0,0.5e0), (0.7e0,-0.6e0), (0.1e0,-0.5e0),
456 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
457 DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7e0,-0.8e0),
458 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
459 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
460 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
461 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
462 + (0.0e0,0.0e0), (0.7e0,-0.6e0), (-0.4e0,-0.7e0),
463 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
464 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.8e0,-0.7e0),
465 + (-0.4e0,-0.7e0), (-0.1e0,-0.2e0),
466 + (0.2e0,-0.8e0), (0.7e0,-0.6e0), (0.1e0,0.4e0),
467 + (0.6e0,-0.6e0)/
468 DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7e0,-0.8e0),
469 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
470 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
471 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
472 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
473 + (0.0e0,0.0e0), (-0.9e0,0.5e0), (-0.4e0,-0.7e0),
474 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
475 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.1e0,-0.5e0),
476 + (-0.4e0,-0.7e0), (0.7e0,-0.6e0), (0.2e0,-0.8e0),
477 + (-0.9e0,0.5e0), (0.1e0,0.4e0), (0.6e0,-0.6e0)/
478 DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7e0,-0.8e0),
479 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
480 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
481 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
482 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
483 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (0.7e0,-0.6e0),
484 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
485 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
486 + (0.7e0,-0.6e0), (-0.1e0,-0.2e0), (0.8e0,-0.7e0),
487 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
488 DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
489 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
490 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
491 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
492 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
493 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.4e0,-0.7e0),
494 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
495 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
496 + (-0.4e0,-0.7e0), (-0.1e0,-0.9e0),
497 + (0.2e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
498 + (0.0e0,0.0e0)/
499 DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
500 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
501 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
502 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
503 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
504 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (-0.9e0,0.5e0),
505 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
506 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
507 + (-0.9e0,0.5e0), (-0.9e0,-0.4e0), (0.1e0,-0.5e0),
508 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
509 + (0.7e0,-0.8e0)/
510 DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
511 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
512 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
513 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
514 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
515 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (0.7e0,-0.8e0),
516 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
517 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
518 + (-0.9e0,-0.4e0), (-0.1e0,-0.9e0),
519 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
520 + (0.0e0,0.0e0)/
521 DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
522 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
523 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
524 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
525 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
526 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.9e0,0.5e0),
527 + (-0.4e0,-0.7e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
528 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
529 + (-0.9e0,0.5e0), (-0.4e0,-0.7e0), (0.1e0,-0.5e0),
530 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
531 + (0.2e0,-0.8e0)/
532 DATA csize1/(0.0e0,0.0e0), (0.9e0,0.9e0),
533 + (1.63e0,1.73e0), (2.90e0,2.78e0)/
534 DATA csize3/(0.0e0,0.0e0), (0.0e0,0.0e0),
535 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
536 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.17e0,1.17e0),
537 + (1.17e0,1.17e0), (1.17e0,1.17e0),
538 + (1.17e0,1.17e0), (1.17e0,1.17e0),
539 + (1.17e0,1.17e0), (1.17e0,1.17e0)/
540 DATA csize2/(0.0e0,0.0e0), (0.0e0,0.0e0),
541 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
542 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.54e0,1.54e0),
543 + (1.54e0,1.54e0), (1.54e0,1.54e0),
544 + (1.54e0,1.54e0), (1.54e0,1.54e0),
545 + (1.54e0,1.54e0), (1.54e0,1.54e0)/
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* .. CDOTC ..
565 cdot(1) = cdotc(n,cx,incx,cy,incy)
566 CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
567 ELSE IF (icase.EQ.2) THEN
568* .. CDOTU ..
569 cdot(1) = cdotu(n,cx,incx,cy,incy)
570 CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
571 ELSE IF (icase.EQ.3) THEN
572* .. CAXPY ..
573 CALL caxpy(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* .. CCOPY ..
577 CALL ccopy(n,cx,incx,cy,incy)
578 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
579 IF (ki.EQ.1) THEN
580 cx0(1) = (42.0e0,43.0e0)
581 cy0(1) = (44.0e0,45.0e0)
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 ccopy(n,cx0,incx,cy0,incy)
592 CALL ctest(1,cy0,cty0,csize3,1.0e0)
593 incx = lincx
594 incy = lincy
595 END IF
596 ELSE IF (icase.EQ.5) THEN
597* .. CSWAP ..
598 CALL cswap(n,cx,incx,cy,incy)
599 CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0e0)
600 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
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 REAL ZERO
625 parameter(nout=6, zero=0.0e0)
626* .. Scalar Arguments ..
627 REAL SFAC
628 INTEGER LEN
629* .. Array Arguments ..
630 REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
631* .. Scalars in Common ..
632 INTEGER ICASE, INCX, INCY, MODE, N
633 LOGICAL PASS
634* .. Local Scalars ..
635 REAL SD
636 INTEGER I
637* .. External Functions ..
638 REAL 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,2e36.8,2e12.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 REAL SCOMP1, SFAC, STRUE1
683* .. Array Arguments ..
684 REAL SSIZE(*)
685* .. Local Arrays ..
686 REAL 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 REAL function sdiff(sa,sb)
701* ********************************* SDIFF **************************
702* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
703*
704* .. Scalar Arguments ..
705 REAL 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 REAL SFAC
720 INTEGER LEN
721* .. Array Arguments ..
722 COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
723* .. Local Scalars ..
724 INTEGER I
725* .. Local Arrays ..
726 REAL SCOMP(20), SSIZE(20), STRUE(20)
727* .. External Subroutines ..
728 EXTERNAL stest
729* .. Intrinsic Functions ..
730 INTRINSIC aimag, real
731* .. Executable Statements ..
732 DO 20 i = 1, len
733 scomp(2*i-1) = real(ccomp(i))
734 scomp(2*i) = aimag(ccomp(i))
735 strue(2*i-1) = real(ctrue(i))
736 strue(2*i) = aimag(ctrue(i))
737 ssize(2*i-1) = real(csize(i))
738 ssize(2*i) = aimag(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 cb1nrm2(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 REAL THRESH
809*
810* =====================================================================
811* .. Parameters ..
812 INTEGER NMAX, NOUT, NV
813 parameter(nmax=20, nout=6, nv=10)
814 REAL HALF, ONE, THREE, TWO, ZERO
815 parameter(half=0.5e+0, one=1.0e+0, two= 2.0e+0,
816 & three=3.0e+0, zero=0.0e+0)
817* .. External Functions ..
818 REAL SCNRM2
819 EXTERNAL scnrm2
820* .. Intrinsic Functions ..
821 INTRINSIC aimag, abs, cmplx, max, min, real, sqrt
822* .. Model parameters ..
823 REAL BIGNUM, SAFMAX, SAFMIN, SMLNUM, ULP
824 parameter(bignum=0.1014120480e+32,
825 & safmax=0.8507059173e+38,
826 & safmin=0.1175494351e-37,
827 & smlnum=0.9860761315e-31,
828 & ulp=0.1192092896e-06)
829* .. Local Scalars ..
830 COMPLEX ROGUE
831 REAL 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 X(NMAX), Z(NMAX)
837 REAL 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) = sxvals(v0,2)
848 values(10) = sxvals(v0,3)
849 rogue = cmplx(1234.5678e+0,-1234.5678e+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) "SCNRM2", 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) = cmplx(v0,-three*v0)
890 DO iw = 1, nv
891 v1 = values(iw)
892 IF (abs(v1).GT.one) THEN
893 v1 = (v1*half) / sqrt(real(ks+1))
894 END IF
895 DO i = 1, n-1
896 z(i+1) = cmplx(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.0e0)
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 SCNRM2 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 SCNRM2 to compute the 2-norm
938*
939 snrm = scnrm2(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(real(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(real(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*real(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) "SCNRM2", 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 REAL FUNCTION SXVALS(XX,K)
994* .. Scalar Arguments ..
995 REAL XX
996 INTEGER K
997* .. Parameters ..
998 REAL ZERO
999 parameter(zero=0.0e+0)
1000* .. Local Scalars ..
1001 REAL 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 sxvals = x
1016 RETURN
1017 END
1018 END
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition cblat1.f:614
cblat1
program cblat1
CBLAT1
Definition cblat1.f:36
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
cb1nrm2
subroutine cb1nrm2(n, incx, thresh)
Definition cblat1.f:791
check1
subroutine check1(sfac)
Definition cblat1.f:122
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
cscal
subroutine cscal(n, ca, cx, incx)
CSCAL
Definition cscal.f:78
cswap
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81