LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
c_cblat1.f
Go to the documentation of this file.
1 PROGRAM ccblat1
2* Test program for the COMPLEX Level 1 CBLAS.
3* Based upon the original CBLAS test routine together with:
4* F06GAF Example Program Text
5* .. Parameters ..
6 INTEGER nout
7 parameter(nout=6)
8* .. Scalars in Common ..
9 INTEGER icase, incx, incy, mode, n
10 LOGICAL pass
11* .. Local Scalars ..
12 REAL sfac
13 INTEGER ic
14* .. External Subroutines ..
15 EXTERNAL check1, check2, header
16* .. Common blocks ..
17 COMMON /combla/icase, n, incx, incy, mode, pass
18* .. Data statements ..
19 DATA sfac/9.765625e-4/
20* .. Executable Statements ..
21 WRITE (nout,99999)
22 DO 20 ic = 1, 10
23 icase = ic
24 CALL header
25*
26* Initialize PASS, INCX, INCY, and MODE for a new case.
27* The value 9999 for INCX, INCY or MODE will appear in the
28* detailed output, if any, for cases that do not involve
29* these parameters.
30*
31 pass = .true.
32 incx = 9999
33 incy = 9999
34 mode = 9999
35 IF (icase.LE.5) THEN
36 CALL check2(sfac)
37 ELSE IF (icase.GE.6) THEN
38 CALL check1(sfac)
39 END IF
40* -- Print
41 IF (pass) WRITE (nout,99998)
42 20 CONTINUE
43 stop
44*
4599999 FORMAT (' Complex CBLAS Test Program Results',/1x)
4699998 FORMAT (' ----- PASS -----')
47 END
48 SUBROUTINE header
49* .. Parameters ..
50 INTEGER NOUT
51 parameter(nout=6)
52* .. Scalars in Common ..
53 INTEGER ICASE, INCX, INCY, MODE, N
54 LOGICAL PASS
55* .. Local Arrays ..
56 CHARACTER*15 L(10)
57* .. Common blocks ..
58 COMMON /combla/icase, n, incx, incy, mode, pass
59* .. Data statements ..
60 DATA l(1)/'CBLAS_CDOTC'/
61 DATA l(2)/'CBLAS_CDOTU'/
62 DATA l(3)/'CBLAS_CAXPY'/
63 DATA l(4)/'CBLAS_CCOPY'/
64 DATA l(5)/'CBLAS_CSWAP'/
65 DATA l(6)/'CBLAS_SCNRM2'/
66 DATA l(7)/'CBLAS_SCASUM'/
67 DATA l(8)/'CBLAS_CSCAL'/
68 DATA l(9)/'CBLAS_CSSCAL'/
69 DATA l(10)/'CBLAS_ICAMAX'/
70* .. Executable Statements ..
71 WRITE (nout,99999) icase, l(icase)
72 RETURN
73*
7499999 FORMAT (/' Test of subprogram number',i3,9x,a15)
75 END
76 SUBROUTINE check1(SFAC)
77* .. Parameters ..
78 INTEGER NOUT
79 parameter(nout=6)
80* .. Scalar Arguments ..
81 REAL SFAC
82* .. Scalars in Common ..
83 INTEGER ICASE, INCX, INCY, MODE, N
84 LOGICAL PASS
85* .. Local Scalars ..
86 COMPLEX CA
87 REAL SA
88 INTEGER I, J, LEN, NP1
89* .. Local Arrays ..
90 COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8),
91 + MWPCS(5), MWPCT(5)
92 REAL STRUE2(5), STRUE4(5)
93 INTEGER ITRUE3(5)
94* .. External Functions ..
95 REAL SCASUMTEST, SCNRM2TEST
96 INTEGER ICAMAXTEST
97 EXTERNAL scasumtest, scnrm2test, icamaxtest
98* .. External Subroutines ..
99 EXTERNAL cscal, csscaltest, ctest, itest1, stest1
100* .. Intrinsic Functions ..
101 INTRINSIC max
102* .. Common blocks ..
103 COMMON /combla/icase, n, incx, incy, mode, pass
104* .. Data statements ..
105 DATA sa, ca/0.3e0, (0.4e0,-0.7e0)/
106 DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
107 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
108 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
109 + (1.0e0,2.0e0), (0.3e0,-0.4e0), (3.0e0,4.0e0),
110 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
111 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
112 + (0.1e0,-0.3e0), (0.5e0,-0.1e0), (5.0e0,6.0e0),
113 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
114 + (5.0e0,6.0e0), (5.0e0,6.0e0), (0.1e0,0.1e0),
115 + (-0.6e0,0.1e0), (0.1e0,-0.3e0), (7.0e0,8.0e0),
116 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
117 + (7.0e0,8.0e0), (0.3e0,0.1e0), (0.1e0,0.4e0),
118 + (0.4e0,0.1e0), (0.1e0,0.2e0), (2.0e0,3.0e0),
119 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
120 DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
121 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
122 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
123 + (4.0e0,5.0e0), (0.3e0,-0.4e0), (6.0e0,7.0e0),
124 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
125 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
126 + (0.1e0,-0.3e0), (8.0e0,9.0e0), (0.5e0,-0.1e0),
127 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
128 + (2.0e0,5.0e0), (2.0e0,5.0e0), (0.1e0,0.1e0),
129 + (3.0e0,6.0e0), (-0.6e0,0.1e0), (4.0e0,7.0e0),
130 + (0.1e0,-0.3e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
131 + (7.0e0,2.0e0), (0.3e0,0.1e0), (5.0e0,8.0e0),
132 + (0.1e0,0.4e0), (6.0e0,9.0e0), (0.4e0,0.1e0),
133 + (8.0e0,3.0e0), (0.1e0,0.2e0), (9.0e0,4.0e0)/
134 DATA strue2/0.0e0, 0.5e0, 0.6e0, 0.7e0, 0.7e0/
135 DATA strue4/0.0e0, 0.7e0, 1.0e0, 1.3e0, 1.7e0/
136 DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
137 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
138 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
139 + (1.0e0,2.0e0), (-0.16e0,-0.37e0), (3.0e0,4.0e0),
140 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
141 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
142 + (-0.17e0,-0.19e0), (0.13e0,-0.39e0),
143 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
144 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
145 + (0.11e0,-0.03e0), (-0.17e0,0.46e0),
146 + (-0.17e0,-0.19e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
147 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
148 + (0.19e0,-0.17e0), (0.32e0,0.09e0),
149 + (0.23e0,-0.24e0), (0.18e0,0.01e0),
150 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0),
151 + (2.0e0,3.0e0)/
152 DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
153 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
154 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
155 + (4.0e0,5.0e0), (-0.16e0,-0.37e0), (6.0e0,7.0e0),
156 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
157 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
158 + (-0.17e0,-0.19e0), (8.0e0,9.0e0),
159 + (0.13e0,-0.39e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
160 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
161 + (0.11e0,-0.03e0), (3.0e0,6.0e0),
162 + (-0.17e0,0.46e0), (4.0e0,7.0e0),
163 + (-0.17e0,-0.19e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
164 + (7.0e0,2.0e0), (0.19e0,-0.17e0), (5.0e0,8.0e0),
165 + (0.32e0,0.09e0), (6.0e0,9.0e0),
166 + (0.23e0,-0.24e0), (8.0e0,3.0e0),
167 + (0.18e0,0.01e0), (9.0e0,4.0e0)/
168 DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
169 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
170 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
171 + (1.0e0,2.0e0), (0.09e0,-0.12e0), (3.0e0,4.0e0),
172 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
173 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
174 + (0.03e0,-0.09e0), (0.15e0,-0.03e0),
175 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
176 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
177 + (0.03e0,0.03e0), (-0.18e0,0.03e0),
178 + (0.03e0,-0.09e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
179 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
180 + (0.09e0,0.03e0), (0.03e0,0.12e0),
181 + (0.12e0,0.03e0), (0.03e0,0.06e0), (2.0e0,3.0e0),
182 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
183 DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
184 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
185 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
186 + (4.0e0,5.0e0), (0.09e0,-0.12e0), (6.0e0,7.0e0),
187 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
188 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
189 + (0.03e0,-0.09e0), (8.0e0,9.0e0),
190 + (0.15e0,-0.03e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
191 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
192 + (0.03e0,0.03e0), (3.0e0,6.0e0),
193 + (-0.18e0,0.03e0), (4.0e0,7.0e0),
194 + (0.03e0,-0.09e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
195 + (7.0e0,2.0e0), (0.09e0,0.03e0), (5.0e0,8.0e0),
196 + (0.03e0,0.12e0), (6.0e0,9.0e0), (0.12e0,0.03e0),
197 + (8.0e0,3.0e0), (0.03e0,0.06e0), (9.0e0,4.0e0)/
198 DATA itrue3/0, 1, 2, 2, 2/
199* .. Executable Statements ..
200 DO 60 incx = 1, 2
201 DO 40 np1 = 1, 5
202 n = np1 - 1
203 len = 2*max(n,1)
204* .. Set vector arguments ..
205 DO 20 i = 1, len
206 cx(i) = cv(i,np1,incx)
207 20 CONTINUE
208 IF (icase.EQ.6) THEN
209* .. SCNRM2TEST ..
210 CALL stest1(scnrm2test(n,cx,incx),strue2(np1),
211 + strue2(np1), sfac)
212 ELSE IF (icase.EQ.7) THEN
213* .. SCASUMTEST ..
214 CALL stest1(scasumtest(n,cx,incx),strue4(np1),
215 + strue4(np1),sfac)
216 ELSE IF (icase.EQ.8) THEN
217* .. CSCAL ..
218 CALL cscal(n,ca,cx,incx)
219 CALL ctest(len,cx,ctrue5(1,np1,incx),ctrue5(1,np1,incx),
220 + sfac)
221 ELSE IF (icase.EQ.9) THEN
222* .. CSSCALTEST ..
223 CALL csscaltest(n,sa,cx,incx)
224 CALL ctest(len,cx,ctrue6(1,np1,incx),ctrue6(1,np1,incx),
225 + sfac)
226 ELSE IF (icase.EQ.10) THEN
227* .. ICAMAXTEST ..
228 CALL itest1(icamaxtest(n,cx,incx),itrue3(np1))
229 ELSE
230 WRITE (nout,*) ' Shouldn''t be here in CHECK1'
231 stop
232 END IF
233*
234 40 CONTINUE
235 60 CONTINUE
236*
237 incx = 1
238 IF (icase.EQ.8) THEN
239* CSCAL
240* Add a test for alpha equal to zero.
241 ca = (0.0e0,0.0e0)
242 DO 80 i = 1, 5
243 mwpct(i) = (0.0e0,0.0e0)
244 mwpcs(i) = (1.0e0,1.0e0)
245 80 CONTINUE
246 CALL cscal(5,ca,cx,incx)
247 CALL ctest(5,cx,mwpct,mwpcs,sfac)
248 ELSE IF (icase.EQ.9) THEN
249* CSSCALTEST
250* Add a test for alpha equal to zero.
251 sa = 0.0e0
252 DO 100 i = 1, 5
253 mwpct(i) = (0.0e0,0.0e0)
254 mwpcs(i) = (1.0e0,1.0e0)
255 100 CONTINUE
256 CALL csscaltest(5,sa,cx,incx)
257 CALL ctest(5,cx,mwpct,mwpcs,sfac)
258* Add a test for alpha equal to one.
259 sa = 1.0e0
260 DO 120 i = 1, 5
261 mwpct(i) = cx(i)
262 mwpcs(i) = cx(i)
263 120 CONTINUE
264 CALL csscaltest(5,sa,cx,incx)
265 CALL ctest(5,cx,mwpct,mwpcs,sfac)
266* Add a test for alpha equal to minus one.
267 sa = -1.0e0
268 DO 140 i = 1, 5
269 mwpct(i) = -cx(i)
270 mwpcs(i) = -cx(i)
271 140 CONTINUE
272 CALL csscaltest(5,sa,cx,incx)
273 CALL ctest(5,cx,mwpct,mwpcs,sfac)
274 END IF
275 RETURN
276 END
277 SUBROUTINE check2(SFAC)
278* .. Parameters ..
279 INTEGER NOUT
280 parameter(nout=6)
281* .. Scalar Arguments ..
282 REAL SFAC
283* .. Scalars in Common ..
284 INTEGER ICASE, INCX, INCY, MODE, N
285 LOGICAL PASS
286* .. Local Scalars ..
287 COMPLEX CA,CTEMP
288 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
289* .. Local Arrays ..
290 COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
291 + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
292 + CT8(7,4,4), CX(7), CX1(7), CY(7), CY1(7)
293 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
294* .. External Functions ..
295 EXTERNAL cdotctest, cdotutest
296* .. External Subroutines ..
297 EXTERNAL caxpytest, ccopytest, cswaptest, ctest
298* .. Intrinsic Functions ..
299 INTRINSIC abs, min
300* .. Common blocks ..
301 COMMON /combla/icase, n, incx, incy, mode, pass
302* .. Data statements ..
303 DATA ca/(0.4e0,-0.7e0)/
304 DATA incxs/1, 2, -2, -1/
305 DATA incys/1, -2, 1, -2/
306 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
307 DATA ns/0, 1, 2, 4/
308 DATA cx1/(0.7e0,-0.8e0), (-0.4e0,-0.7e0),
309 + (-0.1e0,-0.9e0), (0.2e0,-0.8e0),
310 + (-0.9e0,-0.4e0), (0.1e0,0.4e0), (-0.6e0,0.6e0)/
311 DATA cy1/(0.6e0,-0.6e0), (-0.9e0,0.5e0),
312 + (0.7e0,-0.6e0), (0.1e0,-0.5e0), (-0.1e0,-0.2e0),
313 + (-0.5e0,-0.3e0), (0.8e0,-0.7e0)/
314 DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
315 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
316 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
317 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
318 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
319 + (0.0e0,0.0e0), (0.32e0,-1.41e0),
320 + (-1.55e0,0.5e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
321 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
322 + (0.32e0,-1.41e0), (-1.55e0,0.5e0),
323 + (0.03e0,-0.89e0), (-0.38e0,-0.96e0),
324 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
325 DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
326 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
327 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
328 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
329 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
330 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
331 + (-0.9e0,0.5e0), (0.42e0,-1.41e0), (0.0e0,0.0e0),
332 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
333 + (0.78e0,0.06e0), (-0.9e0,0.5e0),
334 + (0.06e0,-0.13e0), (0.1e0,-0.5e0),
335 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
336 + (0.52e0,-1.51e0)/
337 DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
338 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
339 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
340 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
341 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
342 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
343 + (-1.18e0,-0.31e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
344 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
345 + (0.78e0,0.06e0), (-1.54e0,0.97e0),
346 + (0.03e0,-0.89e0), (-0.18e0,-1.31e0),
347 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
348 DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
349 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
350 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
351 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
352 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
353 + (0.0e0,0.0e0), (0.32e0,-1.41e0), (-0.9e0,0.5e0),
354 + (0.05e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
355 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.32e0,-1.41e0),
356 + (-0.9e0,0.5e0), (0.05e0,-0.6e0), (0.1e0,-0.5e0),
357 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
358 + (0.32e0,-1.16e0)/
359 DATA ct7/(0.0e0,0.0e0), (-0.06e0,-0.90e0),
360 + (0.65e0,-0.47e0), (-0.34e0,-1.22e0),
361 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
362 + (-0.59e0,-1.46e0), (-1.04e0,-0.04e0),
363 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
364 + (-0.83e0,0.59e0), (0.07e0,-0.37e0),
365 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
366 + (-0.76e0,-1.15e0), (-1.33e0,-1.82e0)/
367 DATA ct6/(0.0e0,0.0e0), (0.90e0,0.06e0),
368 + (0.91e0,-0.77e0), (1.80e0,-0.10e0),
369 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.45e0,0.74e0),
370 + (0.20e0,0.90e0), (0.0e0,0.0e0), (0.90e0,0.06e0),
371 + (-0.55e0,0.23e0), (0.83e0,-0.39e0),
372 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.04e0,0.79e0),
373 + (1.95e0,1.22e0)/
374 DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7e0,-0.8e0),
375 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
376 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
377 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
378 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
379 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (-0.9e0,0.5e0),
380 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
381 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
382 + (-0.9e0,0.5e0), (0.7e0,-0.6e0), (0.1e0,-0.5e0),
383 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
384 DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7e0,-0.8e0),
385 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
386 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
387 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
388 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
389 + (0.0e0,0.0e0), (0.7e0,-0.6e0), (-0.4e0,-0.7e0),
390 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
391 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.8e0,-0.7e0),
392 + (-0.4e0,-0.7e0), (-0.1e0,-0.2e0),
393 + (0.2e0,-0.8e0), (0.7e0,-0.6e0), (0.1e0,0.4e0),
394 + (0.6e0,-0.6e0)/
395 DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7e0,-0.8e0),
396 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
397 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
398 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
399 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
400 + (0.0e0,0.0e0), (-0.9e0,0.5e0), (-0.4e0,-0.7e0),
401 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
402 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.1e0,-0.5e0),
403 + (-0.4e0,-0.7e0), (0.7e0,-0.6e0), (0.2e0,-0.8e0),
404 + (-0.9e0,0.5e0), (0.1e0,0.4e0), (0.6e0,-0.6e0)/
405 DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7e0,-0.8e0),
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.6e0,-0.6e0), (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.6e0,-0.6e0), (0.7e0,-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.6e0,-0.6e0),
413 + (0.7e0,-0.6e0), (-0.1e0,-0.2e0), (0.8e0,-0.7e0),
414 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
415 DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
416 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
417 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
418 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
419 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
420 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.4e0,-0.7e0),
421 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
422 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
423 + (-0.4e0,-0.7e0), (-0.1e0,-0.9e0),
424 + (0.2e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
425 + (0.0e0,0.0e0)/
426 DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
427 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
428 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
429 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
430 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
431 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (-0.9e0,0.5e0),
432 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
433 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
434 + (-0.9e0,0.5e0), (-0.9e0,-0.4e0), (0.1e0,-0.5e0),
435 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
436 + (0.7e0,-0.8e0)/
437 DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
438 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
439 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
440 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
441 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
442 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (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.6e0,0.6e0),
445 + (-0.9e0,-0.4e0), (-0.1e0,-0.9e0),
446 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
447 + (0.0e0,0.0e0)/
448 DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
449 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
450 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
451 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
452 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
453 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.9e0,0.5e0),
454 + (-0.4e0,-0.7e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
455 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
456 + (-0.9e0,0.5e0), (-0.4e0,-0.7e0), (0.1e0,-0.5e0),
457 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
458 + (0.2e0,-0.8e0)/
459 DATA csize1/(0.0e0,0.0e0), (0.9e0,0.9e0),
460 + (1.63e0,1.73e0), (2.90e0,2.78e0)/
461 DATA csize3/(0.0e0,0.0e0), (0.0e0,0.0e0),
462 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
463 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.17e0,1.17e0),
464 + (1.17e0,1.17e0), (1.17e0,1.17e0),
465 + (1.17e0,1.17e0), (1.17e0,1.17e0),
466 + (1.17e0,1.17e0), (1.17e0,1.17e0)/
467 DATA csize2/(0.0e0,0.0e0), (0.0e0,0.0e0),
468 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
469 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.54e0,1.54e0),
470 + (1.54e0,1.54e0), (1.54e0,1.54e0),
471 + (1.54e0,1.54e0), (1.54e0,1.54e0),
472 + (1.54e0,1.54e0), (1.54e0,1.54e0)/
473* .. Executable Statements ..
474 DO 60 ki = 1, 4
475 incx = incxs(ki)
476 incy = incys(ki)
477 mx = abs(incx)
478 my = abs(incy)
479*
480 DO 40 kn = 1, 4
481 n = ns(kn)
482 ksize = min(2,kn)
483 lenx = lens(kn,mx)
484 leny = lens(kn,my)
485* .. initialize all argument arrays ..
486 DO 20 i = 1, 7
487 cx(i) = cx1(i)
488 cy(i) = cy1(i)
489 20 CONTINUE
490 IF (icase.EQ.1) THEN
491* .. CDOTCTEST ..
492 CALL cdotctest(n,cx,incx,cy,incy,ctemp)
493 cdot(1) = ctemp
494 CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
495 ELSE IF (icase.EQ.2) THEN
496* .. CDOTUTEST ..
497 CALL cdotutest(n,cx,incx,cy,incy,ctemp)
498 cdot(1) = ctemp
499 CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
500 ELSE IF (icase.EQ.3) THEN
501* .. CAXPYTEST ..
502 CALL caxpytest(n,ca,cx,incx,cy,incy)
503 CALL ctest(leny,cy,ct8(1,kn,ki),csize2(1,ksize),sfac)
504 ELSE IF (icase.EQ.4) THEN
505* .. CCOPYTEST ..
506 CALL ccopytest(n,cx,incx,cy,incy)
507 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
508 ELSE IF (icase.EQ.5) THEN
509* .. CSWAPTEST ..
510 CALL cswaptest(n,cx,incx,cy,incy)
511 CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0e0)
512 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
513 ELSE
514 WRITE (nout,*) ' Shouldn''t be here in CHECK2'
515 stop
516 END IF
517*
518 40 CONTINUE
519 60 CONTINUE
520 RETURN
521 END
522 SUBROUTINE stest(LEN,SCOMP,STRUE,SSIZE,SFAC)
523* ********************************* STEST **************************
524*
525* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
526* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
527* NEGLIGIBLE.
528*
529* C. L. LAWSON, JPL, 1974 DEC 10
530*
531* .. Parameters ..
532 INTEGER NOUT
533 parameter(nout=6)
534* .. Scalar Arguments ..
535 REAL SFAC
536 INTEGER LEN
537* .. Array Arguments ..
538 REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
539* .. Scalars in Common ..
540 INTEGER ICASE, INCX, INCY, MODE, N
541 LOGICAL PASS
542* .. Local Scalars ..
543 REAL SD
544 INTEGER I
545* .. External Functions ..
546 REAL SDIFF
547 EXTERNAL sdiff
548* .. Intrinsic Functions ..
549 INTRINSIC abs
550* .. Common blocks ..
551 COMMON /combla/icase, n, incx, incy, mode, pass
552* .. Executable Statements ..
553*
554 DO 40 i = 1, len
555 sd = scomp(i) - strue(i)
556 IF (sdiff(abs(ssize(i))+abs(sfac*sd),abs(ssize(i))).EQ.0.0e0)
557 + GO TO 40
558*
559* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
560*
561 IF ( .NOT. pass) GO TO 20
562* PRINT FAIL MESSAGE AND HEADER.
563 pass = .false.
564 WRITE (nout,99999)
565 WRITE (nout,99998)
566 20 WRITE (nout,99997) icase, n, incx, incy, mode, i, scomp(i),
567 + strue(i), sd, ssize(i)
568 40 CONTINUE
569 RETURN
570*
57199999 FORMAT (' FAIL')
57299998 FORMAT (/' CASE N INCX INCY MODE I ',
573 + ' COMP(I) TRUE(I) DIFFERENCE',
574 + ' SIZE(I)',/1x)
57599997 FORMAT (1x,i4,i3,3i5,i3,2e36.8,2e12.4)
576 END
577 SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
578* ************************* STEST1 *****************************
579*
580* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
581* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
582* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
583*
584* C.L. LAWSON, JPL, 1978 DEC 6
585*
586* .. Scalar Arguments ..
587 REAL SCOMP1, SFAC, STRUE1
588* .. Array Arguments ..
589 REAL SSIZE(*)
590* .. Local Arrays ..
591 REAL SCOMP(1), STRUE(1)
592* .. External Subroutines ..
593 EXTERNAL stest
594* .. Executable Statements ..
595*
596 scomp(1) = scomp1
597 strue(1) = strue1
598 CALL stest(1,scomp,strue,ssize,sfac)
599*
600 RETURN
601 END
602 REAL function sdiff(sa,sb)
603* ********************************* SDIFF **************************
604* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
605*
606* .. Scalar Arguments ..
607 REAL sa, sb
608* .. Executable Statements ..
609 sdiff = sa - sb
610 RETURN
611 END
612 SUBROUTINE ctest(LEN,CCOMP,CTRUE,CSIZE,SFAC)
613* **************************** CTEST *****************************
614*
615* C.L. LAWSON, JPL, 1978 DEC 6
616*
617* .. Scalar Arguments ..
618 REAL SFAC
619 INTEGER LEN
620* .. Array Arguments ..
621 COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
622* .. Local Scalars ..
623 INTEGER I
624* .. Local Arrays ..
625 REAL SCOMP(20), SSIZE(20), STRUE(20)
626* .. External Subroutines ..
627 EXTERNAL stest
628* .. Intrinsic Functions ..
629 INTRINSIC aimag, real
630* .. Executable Statements ..
631 DO 20 i = 1, len
632 scomp(2*i-1) = real(ccomp(i))
633 scomp(2*i) = aimag(ccomp(i))
634 strue(2*i-1) = real(ctrue(i))
635 strue(2*i) = aimag(ctrue(i))
636 ssize(2*i-1) = real(csize(i))
637 ssize(2*i) = aimag(csize(i))
638 20 CONTINUE
639*
640 CALL stest(2*len,scomp,strue,ssize,sfac)
641 RETURN
642 END
643 SUBROUTINE itest1(ICOMP,ITRUE)
644* ********************************* ITEST1 *************************
645*
646* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
647* EQUALITY.
648* C. L. LAWSON, JPL, 1974 DEC 10
649*
650* .. Parameters ..
651 INTEGER NOUT
652 parameter(nout=6)
653* .. Scalar Arguments ..
654 INTEGER ICOMP, ITRUE
655* .. Scalars in Common ..
656 INTEGER ICASE, INCX, INCY, MODE, N
657 LOGICAL PASS
658* .. Local Scalars ..
659 INTEGER ID
660* .. Common blocks ..
661 COMMON /combla/icase, n, incx, incy, mode, pass
662* .. Executable Statements ..
663 IF (icomp.EQ.itrue) GO TO 40
664*
665* HERE ICOMP IS NOT EQUAL TO ITRUE.
666*
667 IF ( .NOT. pass) GO TO 20
668* PRINT FAIL MESSAGE AND HEADER.
669 pass = .false.
670 WRITE (nout,99999)
671 WRITE (nout,99998)
672 20 id = icomp - itrue
673 WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
674 40 CONTINUE
675 RETURN
676*
67799999 FORMAT (' FAIL')
67899998 FORMAT (/' CASE N INCX INCY MODE ',
679 + ' COMP TRUE DIFFERENCE',
680 + /1x)
68199997 FORMAT (1x,i4,i3,3i5,2i36,i12)
682 END
ccblat1
program ccblat1
Definition c_cblat1.f:1
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition cblat1.f:614
ctest
subroutine ctest(len, ccomp, ctrue, csize, sfac)
Definition cblat1.f:714
stest1
subroutine stest1(scomp1, strue1, ssize, sfac)
Definition cblat1.f:673
itest1
subroutine itest1(icomp, itrue)
Definition cblat1.f:748
header
subroutine header
Definition cblat1.f:91
sdiff
real function sdiff(sa, sb)
Definition cblat1.f:701
check2
subroutine check2(sfac)
Definition cblat1.f:348
check1
subroutine check1(sfac)
Definition cblat1.f:122
cscal
subroutine cscal(n, ca, cx, incx)
CSCAL
Definition cscal.f:78