LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
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 *
45 99999 FORMAT (' Complex CBLAS Test Program Results',/1x)
46 99998 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 *
74 99999 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 *
571 99999 FORMAT (' FAIL')
572 99998 FORMAT (/' CASE N INCX INCY MODE I ',
573  + ' COMP(I) TRUE(I) DIFFERENCE',
574  + ' SIZE(I)',/1x)
575 99997 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 ACCOMODATE 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 *
677 99999 FORMAT (' FAIL')
678 99998 FORMAT (/' CASE N INCX INCY MODE ',
679  + ' COMP TRUE DIFFERENCE',
680  + /1x)
681 99997 FORMAT (1x,i4,i3,3i5,2i36,i12)
682  END
header
subroutine header
Definition: cblat1.f:91
itest1
subroutine itest1(ICOMP, ITRUE)
Definition: cblat1.f:686
check1
subroutine check1(SFAC)
Definition: cblat1.f:119
cscal
subroutine cscal(N, CA, CX, INCX)
CSCAL
Definition: cscal.f:54
stest1
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:620
check2
subroutine check2(SFAC)
Definition: cblat1.f:320
sdiff
real function sdiff(SA, SB)
Definition: cblat1.f:645
stest
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564
ctest
subroutine ctest(LEN, CCOMP, CTRUE, CSIZE, SFAC)
Definition: cblat1.f:655
ccblat1
program ccblat1
Definition: c_cblat1.f:1