OpenRadioss 2025.1.11
OpenRadioss project
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 parameter(nout=6)
125* .. Scalar Arguments ..
126 REAL SFAC
127* .. Scalars in Common ..
128 INTEGER ICASE, INCX, INCY, MODE, N
129 LOGICAL PASS
130* .. Local Scalars ..
131 COMPLEX CA
132 REAL SA
133 INTEGER I, IX, J, LEN, NP1
134* .. Local Arrays ..
135 COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CVR(8),
136 + CX(8), CXR(15), MWPCS(5), MWPCT(5)
137 REAL STRUE2(5), STRUE4(5)
138 INTEGER ITRUE3(5), ITRUEC(5)
139* .. External Functions ..
140 REAL SCASUM, SCNRM2
141 INTEGER ICAMAX
142 EXTERNAL scasum, scnrm2, icamax
143* .. External Subroutines ..
144 EXTERNAL cscal, csscal, 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.3e0, (0.4e0,-0.7e0)/
151 DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
152 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
153 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
154 + (1.0e0,2.0e0), (0.3e0,-0.4e0), (3.0e0,4.0e0),
155 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
156 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
157 + (0.1e0,-0.3e0), (0.5e0,-0.1e0), (5.0e0,6.0e0),
158 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
159 + (5.0e0,6.0e0), (5.0e0,6.0e0), (0.1e0,0.1e0),
160 + (-0.6e0,0.1e0), (0.1e0,-0.3e0), (7.0e0,8.0e0),
161 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
162 + (7.0e0,8.0e0), (0.3e0,0.1e0), (0.5e0,0.0e0),
163 + (0.0e0,0.5e0), (0.0e0,0.2e0), (2.0e0,3.0e0),
164 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
165 DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
166 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
167 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
168 + (4.0e0,5.0e0), (0.3e0,-0.4e0), (6.0e0,7.0e0),
169 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
170 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
171 + (0.1e0,-0.3e0), (8.0e0,9.0e0), (0.5e0,-0.1e0),
172 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
173 + (2.0e0,5.0e0), (2.0e0,5.0e0), (0.1e0,0.1e0),
174 + (3.0e0,6.0e0), (-0.6e0,0.1e0), (4.0e0,7.0e0),
175 + (0.1e0,-0.3e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
176 + (7.0e0,2.0e0), (0.3e0,0.1e0), (5.0e0,8.0e0),
177 + (0.5e0,0.0e0), (6.0e0,9.0e0), (0.0e0,0.5e0),
178 + (8.0e0,3.0e0), (0.0e0,0.2e0), (9.0e0,4.0e0)/
179 DATA cvr/(8.0e0,8.0e0), (-7.0e0,-7.0e0),
180 + (9.0e0,9.0e0), (5.0e0,5.0e0), (9.0e0,9.0e0),
181 + (8.0e0,8.0e0), (7.0e0,7.0e0), (7.0e0,7.0e0)/
182 DATA strue2/0.0e0, 0.5e0, 0.6e0, 0.7e0, 0.8e0/
183 DATA strue4/0.0e0, 0.7e0, 1.0e0, 1.3e0, 1.6e0/
184 DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
185 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
186 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
187 + (1.0e0,2.0e0), (-0.16e0,-0.37e0), (3.0e0,4.0e0),
188 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
189 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
190 + (-0.17e0,-0.19e0), (0.13e0,-0.39e0),
191 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
192 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
193 + (0.11e0,-0.03e0), (-0.17e0,0.46e0),
194 + (-0.17e0,-0.19e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
195 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
196 + (0.19e0,-0.17e0), (0.20e0,-0.35e0),
197 + (0.35e0,0.20e0), (0.14e0,0.08e0),
198 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0),
199 + (2.0e0,3.0e0)/
200 DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
201 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
202 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
203 + (4.0e0,5.0e0), (-0.16e0,-0.37e0), (6.0e0,7.0e0),
204 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
205 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
206 + (-0.17e0,-0.19e0), (8.0e0,9.0e0),
207 + (0.13e0,-0.39e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
208 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
209 + (0.11e0,-0.03e0), (3.0e0,6.0e0),
210 + (-0.17e0,0.46e0), (4.0e0,7.0e0),
211 + (-0.17e0,-0.19e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
212 + (7.0e0,2.0e0), (0.19e0,-0.17e0), (5.0e0,8.0e0),
213 + (0.20e0,-0.35e0), (6.0e0,9.0e0),
214 + (0.35e0,0.20e0), (8.0e0,3.0e0),
215 + (0.14e0,0.08e0), (9.0e0,4.0e0)/
216 DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
217 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
218 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
219 + (1.0e0,2.0e0), (0.09e0,-0.12e0), (3.0e0,4.0e0),
220 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
221 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
222 + (0.03e0,-0.09e0), (0.15e0,-0.03e0),
223 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
224 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
225 + (0.03e0,0.03e0), (-0.18e0,0.03e0),
226 + (0.03e0,-0.09e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
227 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
228 + (0.09e0,0.03e0), (0.15e0,0.00e0),
229 + (0.00e0,0.15e0), (0.00e0,0.06e0), (2.0e0,3.0e0),
230 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
231 DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
232 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
233 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
234 + (4.0e0,5.0e0), (0.09e0,-0.12e0), (6.0e0,7.0e0),
235 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
236 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
237 + (0.03e0,-0.09e0), (8.0e0,9.0e0),
238 + (0.15e0,-0.03e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
239 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
240 + (0.03e0,0.03e0), (3.0e0,6.0e0),
241 + (-0.18e0,0.03e0), (4.0e0,7.0e0),
242 + (0.03e0,-0.09e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
243 + (7.0e0,2.0e0), (0.09e0,0.03e0), (5.0e0,8.0e0),
244 + (0.15e0,0.00e0), (6.0e0,9.0e0), (0.00e0,0.15e0),
245 + (8.0e0,3.0e0), (0.00e0,0.06e0), (9.0e0,4.0e0)/
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* .. SCNRM2 ..
259 CALL stest1(scnrm2(n,cx,incx),strue2(np1),strue2(np1),
260 + sfac)
261 ELSE IF (icase.EQ.7) THEN
262* .. SCASUM ..
263 CALL stest1(scasum(n,cx,incx),strue4(np1),strue4(np1),
264 + sfac)
265 ELSE IF (icase.EQ.8) THEN
266* .. CSCAL ..
267 CALL cscal(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* .. CSSCAL ..
272 CALL csscal(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* .. ICAMAX ..
277 CALL itest1(icamax(n,cx,incx),itrue3(np1))
278 DO 160 i = 1, len
279 cx(i) = (42.0e0,43.0e0)
280 160 CONTINUE
281 CALL itest1(icamax(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(icamax(n,cxr,incx),3)
296 END IF
297 60 CONTINUE
298*
299 incx = 1
300 IF (icase.EQ.8) THEN
301* CSCAL
302* Add a test for alpha equal to zero.
303 ca = (0.0e0,0.0e0)
304 DO 80 i = 1, 5
305 mwpct(i) = (0.0e0,0.0e0)
306 mwpcs(i) = (1.0e0,1.0e0)
307 80 CONTINUE
308 CALL cscal(5,ca,cx,incx)
309 CALL ctest(5,cx,mwpct,mwpcs,sfac)
310 ELSE IF (icase.EQ.9) THEN
311* CSSCAL
312* Add a test for alpha equal to zero.
313 sa = 0.0e0
314 DO 100 i = 1, 5
315 mwpct(i) = (0.0e0,0.0e0)
316 mwpcs(i) = (1.0e0,1.0e0)
317 100 CONTINUE
318 CALL csscal(5,sa,cx,incx)
319 CALL ctest(5,cx,mwpct,mwpcs,sfac)
320* Add a test for alpha equal to one.
321 sa = 1.0e0
322 DO 120 i = 1, 5
323 mwpct(i) = cx(i)
324 mwpcs(i) = cx(i)
325 120 CONTINUE
326 CALL csscal(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.0e0
330 DO 140 i = 1, 5
331 mwpct(i) = -cx(i)
332 mwpcs(i) = -cx(i)
333 140 CONTINUE
334 CALL csscal(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 REAL SFAC
348* .. Scalars in Common ..
349 INTEGER ICASE, INCX, INCY, MODE, N
350 LOGICAL PASS
351* .. Local Scalars ..
352 COMPLEX CA
353 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
354 + MX, MY
355* .. Local Arrays ..
356 COMPLEX 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 CDOTC, CDOTU
363 EXTERNAL cdotc, cdotu
364* .. External Subroutines ..
365 EXTERNAL caxpy, ccopy, cswap, 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.4e0,-0.7e0)/
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.7e0,-0.8e0), (-0.4e0,-0.7e0),
377 + (-0.1e0,-0.9e0), (0.2e0,-0.8e0),
378 + (-0.9e0,-0.4e0), (0.1e0,0.4e0), (-0.6e0,0.6e0)/
379 DATA cy1/(0.6e0,-0.6e0), (-0.9e0,0.5e0),
380 + (0.7e0,-0.6e0), (0.1e0,-0.5e0), (-0.1e0,-0.2e0),
381 + (-0.5e0,-0.3e0), (0.8e0,-0.7e0)/
382 DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
383 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
384 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
385 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
386 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
387 + (0.0e0,0.0e0), (0.32e0,-1.41e0),
388 + (-1.55e0,0.5e0), (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), (-1.55e0,0.5e0),
391 + (0.03e0,-0.89e0), (-0.38e0,-0.96e0),
392 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
393 DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
394 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
395 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
396 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
397 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
398 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
399 + (-0.9e0,0.5e0), (0.42e0,-1.41e0), (0.0e0,0.0e0),
400 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
401 + (0.78e0,0.06e0), (-0.9e0,0.5e0),
402 + (0.06e0,-0.13e0), (0.1e0,-0.5e0),
403 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
404 + (0.52e0,-1.51e0)/
405 DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
406 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
407 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
408 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
409 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
410 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
411 + (-1.18e0,-0.31e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
412 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
413 + (0.78e0,0.06e0), (-1.54e0,0.97e0),
414 + (0.03e0,-0.89e0), (-0.18e0,-1.31e0),
415 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
416 DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
417 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
418 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
419 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
420 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
421 + (0.0e0,0.0e0), (0.32e0,-1.41e0), (-0.9e0,0.5e0),
422 + (0.05e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
423 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.32e0,-1.41e0),
424 + (-0.9e0,0.5e0), (0.05e0,-0.6e0), (0.1e0,-0.5e0),
425 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
426 + (0.32e0,-1.16e0)/
427 DATA ct7/(0.0e0,0.0e0), (-0.06e0,-0.90e0),
428 + (0.65e0,-0.47e0), (-0.34e0,-1.22e0),
429 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
430 + (-0.59e0,-1.46e0), (-1.04e0,-0.04e0),
431 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
432 + (-0.83e0,0.59e0), (0.07e0,-0.37e0),
433 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
434 + (-0.76e0,-1.15e0), (-1.33e0,-1.82e0)/
435 DATA ct6/(0.0e0,0.0e0), (0.90e0,0.06e0),
436 + (0.91e0,-0.77e0), (1.80e0,-0.10e0),
437 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.45e0,0.74e0),
438 + (0.20e0,0.90e0), (0.0e0,0.0e0), (0.90e0,0.06e0),
439 + (-0.55e0,0.23e0), (0.83e0,-0.39e0),
440 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.04e0,0.79e0),
441 + (1.95e0,1.22e0)/
442 DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7e0,-0.8e0),
443 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
444 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
445 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
446 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
447 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (-0.9e0,0.5e0),
448 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
449 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
450 + (-0.9e0,0.5e0), (0.7e0,-0.6e0), (0.1e0,-0.5e0),
451 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
452 DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7e0,-0.8e0),
453 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
454 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
455 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
456 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
457 + (0.0e0,0.0e0), (0.7e0,-0.6e0), (-0.4e0,-0.7e0),
458 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
459 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.8e0,-0.7e0),
460 + (-0.4e0,-0.7e0), (-0.1e0,-0.2e0),
461 + (0.2e0,-0.8e0), (0.7e0,-0.6e0), (0.1e0,0.4e0),
462 + (0.6e0,-0.6e0)/
463 DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7e0,-0.8e0),
464 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
465 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
466 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
467 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
468 + (0.0e0,0.0e0), (-0.9e0,0.5e0), (-0.4e0,-0.7e0),
469 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
470 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.1e0,-0.5e0),
471 + (-0.4e0,-0.7e0), (0.7e0,-0.6e0), (0.2e0,-0.8e0),
472 + (-0.9e0,0.5e0), (0.1e0,0.4e0), (0.6e0,-0.6e0)/
473 DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7e0,-0.8e0),
474 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
475 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
476 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
477 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
478 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (0.7e0,-0.6e0),
479 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
480 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
481 + (0.7e0,-0.6e0), (-0.1e0,-0.2e0), (0.8e0,-0.7e0),
482 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
483 DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6e0,-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.0e0,0.0e0),
486 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
487 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
488 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.4e0,-0.7e0),
489 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
490 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
491 + (-0.4e0,-0.7e0), (-0.1e0,-0.9e0),
492 + (0.2e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
493 + (0.0e0,0.0e0)/
494 DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
495 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
496 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
497 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
498 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
499 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (-0.9e0,0.5e0),
500 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
501 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
502 + (-0.9e0,0.5e0), (-0.9e0,-0.4e0), (0.1e0,-0.5e0),
503 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
504 + (0.7e0,-0.8e0)/
505 DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
506 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
507 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
508 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
509 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
510 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (0.7e0,-0.8e0),
511 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
512 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
513 + (-0.9e0,-0.4e0), (-0.1e0,-0.9e0),
514 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
515 + (0.0e0,0.0e0)/
516 DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
517 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
518 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
519 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
520 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
521 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.9e0,0.5e0),
522 + (-0.4e0,-0.7e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
523 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
524 + (-0.9e0,0.5e0), (-0.4e0,-0.7e0), (0.1e0,-0.5e0),
525 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
526 + (0.2e0,-0.8e0)/
527 DATA csize1/(0.0e0,0.0e0), (0.9e0,0.9e0),
528 + (1.63e0,1.73e0), (2.90e0,2.78e0)/
529 DATA csize3/(0.0e0,0.0e0), (0.0e0,0.0e0),
530 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
531 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.17e0,1.17e0),
532 + (1.17e0,1.17e0), (1.17e0,1.17e0),
533 + (1.17e0,1.17e0), (1.17e0,1.17e0),
534 + (1.17e0,1.17e0), (1.17e0,1.17e0)/
535 DATA csize2/(0.0e0,0.0e0), (0.0e0,0.0e0),
536 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
537 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.54e0,1.54e0),
538 + (1.54e0,1.54e0), (1.54e0,1.54e0),
539 + (1.54e0,1.54e0), (1.54e0,1.54e0),
540 + (1.54e0,1.54e0), (1.54e0,1.54e0)/
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* .. CDOTC ..
560 cdot(1) = cdotc(n,cx,incx,cy,incy)
561 CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
562 ELSE IF (icase.EQ.2) THEN
563* .. CDOTU ..
564 cdot(1) = cdotu(n,cx,incx,cy,incy)
565 CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
566 ELSE IF (icase.EQ.3) THEN
567* .. CAXPY ..
568 CALL caxpy(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* .. CCOPY ..
572 CALL ccopy(n,cx,incx,cy,incy)
573 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
574 IF (ki.EQ.1) THEN
575 cx0(1) = (42.0e0,43.0e0)
576 cy0(1) = (44.0e0,45.0e0)
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 ccopy(n,cx0,incx,cy0,incy)
587 CALL ctest(1,cy0,cty0,csize3,1.0e0)
588 incx = lincx
589 incy = lincy
590 END IF
591 ELSE IF (icase.EQ.5) THEN
592* .. CSWAP ..
593 CALL cswap(n,cx,incx,cy,incy)
594 CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0e0)
595 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
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 REAL ZERO
620 parameter(nout=6, zero=0.0e0)
621* .. Scalar Arguments ..
622 REAL SFAC
623 INTEGER LEN
624* .. Array Arguments ..
625 REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
626* .. Scalars in Common ..
627 INTEGER ICASE, INCX, INCY, MODE, N
628 LOGICAL PASS
629* .. Local Scalars ..
630 REAL SD
631 INTEGER I
632* .. External Functions ..
633 REAL 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,2e36.8,2e12.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 REAL SCOMP1, SFAC, STRUE1
678* .. Array Arguments ..
679 REAL SSIZE(*)
680* .. Local Arrays ..
681 REAL 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 REAL function sdiff(sa,sb)
696* ********************************* SDIFF **************************
697* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
698*
699* .. Scalar Arguments ..
700 REAL 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 REAL SFAC
715 INTEGER LEN
716* .. Array Arguments ..
717 COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
718* .. Local Scalars ..
719 INTEGER I
720* .. Local Arrays ..
721 REAL SCOMP(20), SSIZE(20), STRUE(20)
722* .. External Subroutines ..
723 EXTERNAL stest
724* .. Intrinsic Functions ..
725 INTRINSIC aimag, real
726* .. Executable Statements ..
727 DO 20 i = 1, len
728 scomp(2*i-1) = real(ccomp(i))
729 scomp(2*i) = aimag(ccomp(i))
730 strue(2*i-1) = real(ctrue(i))
731 strue(2*i) = aimag(ctrue(i))
732 ssize(2*i-1) = real(csize(i))
733 ssize(2*i) = aimag(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
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition cblat1.f:609
ctest
subroutine ctest(len, ccomp, ctrue, csize, sfac)
Definition cblat1.f:709
stest1
subroutine stest1(scomp1, strue1, ssize, sfac)
Definition cblat1.f:668
itest1
subroutine itest1(icomp, itrue)
Definition cblat1.f:743
header
subroutine header
Definition cblat1.f:91
sdiff
real function sdiff(sa, sb)
Definition cblat1.f:696
check2
subroutine check2(sfac)
Definition cblat1.f:343
check1
subroutine check1(sfac)
Definition cblat1.f:122
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88
cswap
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
cscal
subroutine cscal(n, ca, cx, incx)
CSCAL
Definition cscal.f:78
cblat1
program cblat1
CBLAT1
Definition cblat1.f:36
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21