LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
c_zblat1.f
Go to the documentation of this file.
1  PROGRAM zcblat1
2 * Test program for the COMPLEX*16 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  DOUBLE PRECISION 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.765625d-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_ZDOTC'/
61  DATA l(2)/'CBLAS_ZDOTU'/
62  DATA l(3)/'CBLAS_ZAXPY'/
63  DATA l(4)/'CBLAS_ZCOPY'/
64  DATA l(5)/'CBLAS_ZSWAP'/
65  DATA l(6)/'CBLAS_DZNRM2'/
66  DATA l(7)/'CBLAS_DZASUM'/
67  DATA l(8)/'CBLAS_ZSCAL'/
68  DATA l(9)/'CBLAS_ZDSCAL'/
69  DATA l(10)/'CBLAS_IZAMAX'/
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  DOUBLE PRECISION SFAC
82 * .. Scalars in Common ..
83  INTEGER ICASE, INCX, INCY, MODE, N
84  LOGICAL PASS
85 * .. Local Scalars ..
86  COMPLEX*16 CA
87  DOUBLE PRECISION SA
88  INTEGER I, J, LEN, NP1
89 * .. Local Arrays ..
90  COMPLEX*16 CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8),
91  + mwpcs(5), mwpct(5)
92  DOUBLE PRECISION STRUE2(5), STRUE4(5)
93  INTEGER ITRUE3(5)
94 * .. External Functions ..
95  DOUBLE PRECISION DZASUMTEST, DZNRM2TEST
96  INTEGER IZAMAXTEST
97  EXTERNAL dzasumtest, dznrm2test, izamaxtest
98 * .. External Subroutines ..
99  EXTERNAL zscaltest, zdscaltest, 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.3d0, (0.4d0,-0.7d0)/
106  DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
107  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
108  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
109  + (1.0d0,2.0d0), (0.3d0,-0.4d0), (3.0d0,4.0d0),
110  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
111  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
112  + (0.1d0,-0.3d0), (0.5d0,-0.1d0), (5.0d0,6.0d0),
113  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
114  + (5.0d0,6.0d0), (5.0d0,6.0d0), (0.1d0,0.1d0),
115  + (-0.6d0,0.1d0), (0.1d0,-0.3d0), (7.0d0,8.0d0),
116  + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
117  + (7.0d0,8.0d0), (0.3d0,0.1d0), (0.1d0,0.4d0),
118  + (0.4d0,0.1d0), (0.1d0,0.2d0), (2.0d0,3.0d0),
119  + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
120  DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
121  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
122  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
123  + (4.0d0,5.0d0), (0.3d0,-0.4d0), (6.0d0,7.0d0),
124  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
125  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
126  + (0.1d0,-0.3d0), (8.0d0,9.0d0), (0.5d0,-0.1d0),
127  + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
128  + (2.0d0,5.0d0), (2.0d0,5.0d0), (0.1d0,0.1d0),
129  + (3.0d0,6.0d0), (-0.6d0,0.1d0), (4.0d0,7.0d0),
130  + (0.1d0,-0.3d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
131  + (7.0d0,2.0d0), (0.3d0,0.1d0), (5.0d0,8.0d0),
132  + (0.1d0,0.4d0), (6.0d0,9.0d0), (0.4d0,0.1d0),
133  + (8.0d0,3.0d0), (0.1d0,0.2d0), (9.0d0,4.0d0)/
134  DATA strue2/0.0d0, 0.5d0, 0.6d0, 0.7d0, 0.7d0/
135  DATA strue4/0.0d0, 0.7d0, 1.0d0, 1.3d0, 1.7d0/
136  DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
137  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
138  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
139  + (1.0d0,2.0d0), (-0.16d0,-0.37d0), (3.0d0,4.0d0),
140  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
141  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
142  + (-0.17d0,-0.19d0), (0.13d0,-0.39d0),
143  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
144  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
145  + (0.11d0,-0.03d0), (-0.17d0,0.46d0),
146  + (-0.17d0,-0.19d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
147  + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
148  + (0.19d0,-0.17d0), (0.32d0,0.09d0),
149  + (0.23d0,-0.24d0), (0.18d0,0.01d0),
150  + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0),
151  + (2.0d0,3.0d0)/
152  DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
153  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
154  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
155  + (4.0d0,5.0d0), (-0.16d0,-0.37d0), (6.0d0,7.0d0),
156  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
157  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
158  + (-0.17d0,-0.19d0), (8.0d0,9.0d0),
159  + (0.13d0,-0.39d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
160  + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
161  + (0.11d0,-0.03d0), (3.0d0,6.0d0),
162  + (-0.17d0,0.46d0), (4.0d0,7.0d0),
163  + (-0.17d0,-0.19d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
164  + (7.0d0,2.0d0), (0.19d0,-0.17d0), (5.0d0,8.0d0),
165  + (0.32d0,0.09d0), (6.0d0,9.0d0),
166  + (0.23d0,-0.24d0), (8.0d0,3.0d0),
167  + (0.18d0,0.01d0), (9.0d0,4.0d0)/
168  DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
169  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
170  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
171  + (1.0d0,2.0d0), (0.09d0,-0.12d0), (3.0d0,4.0d0),
172  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
173  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
174  + (0.03d0,-0.09d0), (0.15d0,-0.03d0),
175  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
176  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
177  + (0.03d0,0.03d0), (-0.18d0,0.03d0),
178  + (0.03d0,-0.09d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
179  + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
180  + (0.09d0,0.03d0), (0.03d0,0.12d0),
181  + (0.12d0,0.03d0), (0.03d0,0.06d0), (2.0d0,3.0d0),
182  + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
183  DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
184  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
185  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
186  + (4.0d0,5.0d0), (0.09d0,-0.12d0), (6.0d0,7.0d0),
187  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
188  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
189  + (0.03d0,-0.09d0), (8.0d0,9.0d0),
190  + (0.15d0,-0.03d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
191  + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
192  + (0.03d0,0.03d0), (3.0d0,6.0d0),
193  + (-0.18d0,0.03d0), (4.0d0,7.0d0),
194  + (0.03d0,-0.09d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
195  + (7.0d0,2.0d0), (0.09d0,0.03d0), (5.0d0,8.0d0),
196  + (0.03d0,0.12d0), (6.0d0,9.0d0), (0.12d0,0.03d0),
197  + (8.0d0,3.0d0), (0.03d0,0.06d0), (9.0d0,4.0d0)/
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 * .. DZNRM2TEST ..
210  CALL stest1(dznrm2test(n,cx,incx),strue2(np1),
211  + strue2(np1),sfac)
212  ELSE IF (icase.EQ.7) THEN
213 * .. DZASUMTEST ..
214  CALL stest1(dzasumtest(n,cx,incx),strue4(np1),
215  + strue4(np1),sfac)
216  ELSE IF (icase.EQ.8) THEN
217 * .. ZSCALTEST ..
218  CALL zscaltest(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 * .. ZDSCALTEST ..
223  CALL zdscaltest(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 * .. IZAMAXTEST ..
228  CALL itest1(izamaxtest(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 * ZSCALTEST
240 * Add a test for alpha equal to zero.
241  ca = (0.0d0,0.0d0)
242  DO 80 i = 1, 5
243  mwpct(i) = (0.0d0,0.0d0)
244  mwpcs(i) = (1.0d0,1.0d0)
245  80 CONTINUE
246  CALL zscaltest(5,ca,cx,incx)
247  CALL ctest(5,cx,mwpct,mwpcs,sfac)
248  ELSE IF (icase.EQ.9) THEN
249 * ZDSCALTEST
250 * Add a test for alpha equal to zero.
251  sa = 0.0d0
252  DO 100 i = 1, 5
253  mwpct(i) = (0.0d0,0.0d0)
254  mwpcs(i) = (1.0d0,1.0d0)
255  100 CONTINUE
256  CALL zdscaltest(5,sa,cx,incx)
257  CALL ctest(5,cx,mwpct,mwpcs,sfac)
258 * Add a test for alpha equal to one.
259  sa = 1.0d0
260  DO 120 i = 1, 5
261  mwpct(i) = cx(i)
262  mwpcs(i) = cx(i)
263  120 CONTINUE
264  CALL zdscaltest(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.0d0
268  DO 140 i = 1, 5
269  mwpct(i) = -cx(i)
270  mwpcs(i) = -cx(i)
271  140 CONTINUE
272  CALL zdscaltest(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  DOUBLE PRECISION SFAC
283 * .. Scalars in Common ..
284  INTEGER ICASE, INCX, INCY, MODE, N
285  LOGICAL PASS
286 * .. Local Scalars ..
287  COMPLEX*16 CA,ZTEMP
288  INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
289 * .. Local Arrays ..
290  COMPLEX*16 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 zdotctest, zdotutest
296 * .. External Subroutines ..
297  EXTERNAL zaxpytest, zcopytest, zswaptest, 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.4d0,-0.7d0)/
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.7d0,-0.8d0), (-0.4d0,-0.7d0),
309  + (-0.1d0,-0.9d0), (0.2d0,-0.8d0),
310  + (-0.9d0,-0.4d0), (0.1d0,0.4d0), (-0.6d0,0.6d0)/
311  DATA cy1/(0.6d0,-0.6d0), (-0.9d0,0.5d0),
312  + (0.7d0,-0.6d0), (0.1d0,-0.5d0), (-0.1d0,-0.2d0),
313  + (-0.5d0,-0.3d0), (0.8d0,-0.7d0)/
314  DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
315  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
316  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
317  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
318  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
319  + (0.0d0,0.0d0), (0.32d0,-1.41d0),
320  + (-1.55d0,0.5d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
321  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
322  + (0.32d0,-1.41d0), (-1.55d0,0.5d0),
323  + (0.03d0,-0.89d0), (-0.38d0,-0.96d0),
324  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
325  DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
326  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
327  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
328  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
329  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
330  + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
331  + (-0.9d0,0.5d0), (0.42d0,-1.41d0), (0.0d0,0.0d0),
332  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
333  + (0.78d0,0.06d0), (-0.9d0,0.5d0),
334  + (0.06d0,-0.13d0), (0.1d0,-0.5d0),
335  + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
336  + (0.52d0,-1.51d0)/
337  DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
338  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
339  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
340  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
341  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
342  + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
343  + (-1.18d0,-0.31d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
344  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
345  + (0.78d0,0.06d0), (-1.54d0,0.97d0),
346  + (0.03d0,-0.89d0), (-0.18d0,-1.31d0),
347  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
348  DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
349  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
350  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
351  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
352  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
353  + (0.0d0,0.0d0), (0.32d0,-1.41d0), (-0.9d0,0.5d0),
354  + (0.05d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
355  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.32d0,-1.41d0),
356  + (-0.9d0,0.5d0), (0.05d0,-0.6d0), (0.1d0,-0.5d0),
357  + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
358  + (0.32d0,-1.16d0)/
359  DATA ct7/(0.0d0,0.0d0), (-0.06d0,-0.90d0),
360  + (0.65d0,-0.47d0), (-0.34d0,-1.22d0),
361  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
362  + (-0.59d0,-1.46d0), (-1.04d0,-0.04d0),
363  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
364  + (-0.83d0,0.59d0), (0.07d0,-0.37d0),
365  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
366  + (-0.76d0,-1.15d0), (-1.33d0,-1.82d0)/
367  DATA ct6/(0.0d0,0.0d0), (0.90d0,0.06d0),
368  + (0.91d0,-0.77d0), (1.80d0,-0.10d0),
369  + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.45d0,0.74d0),
370  + (0.20d0,0.90d0), (0.0d0,0.0d0), (0.90d0,0.06d0),
371  + (-0.55d0,0.23d0), (0.83d0,-0.39d0),
372  + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.04d0,0.79d0),
373  + (1.95d0,1.22d0)/
374  DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7d0,-0.8d0),
375  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
376  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
377  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
378  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
379  + (0.0d0,0.0d0), (0.6d0,-0.6d0), (-0.9d0,0.5d0),
380  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
381  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
382  + (-0.9d0,0.5d0), (0.7d0,-0.6d0), (0.1d0,-0.5d0),
383  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
384  DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7d0,-0.8d0),
385  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
386  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
387  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
388  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
389  + (0.0d0,0.0d0), (0.7d0,-0.6d0), (-0.4d0,-0.7d0),
390  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
391  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.8d0,-0.7d0),
392  + (-0.4d0,-0.7d0), (-0.1d0,-0.2d0),
393  + (0.2d0,-0.8d0), (0.7d0,-0.6d0), (0.1d0,0.4d0),
394  + (0.6d0,-0.6d0)/
395  DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7d0,-0.8d0),
396  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
397  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
398  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
399  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
400  + (0.0d0,0.0d0), (-0.9d0,0.5d0), (-0.4d0,-0.7d0),
401  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
402  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.1d0,-0.5d0),
403  + (-0.4d0,-0.7d0), (0.7d0,-0.6d0), (0.2d0,-0.8d0),
404  + (-0.9d0,0.5d0), (0.1d0,0.4d0), (0.6d0,-0.6d0)/
405  DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7d0,-0.8d0),
406  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
407  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
408  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
409  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
410  + (0.0d0,0.0d0), (0.6d0,-0.6d0), (0.7d0,-0.6d0),
411  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
412  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
413  + (0.7d0,-0.6d0), (-0.1d0,-0.2d0), (0.8d0,-0.7d0),
414  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
415  DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
416  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
417  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
418  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
419  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
420  + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.4d0,-0.7d0),
421  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
422  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
423  + (-0.4d0,-0.7d0), (-0.1d0,-0.9d0),
424  + (0.2d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
425  + (0.0d0,0.0d0)/
426  DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
427  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
428  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
429  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
430  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
431  + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (-0.9d0,0.5d0),
432  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
433  + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
434  + (-0.9d0,0.5d0), (-0.9d0,-0.4d0), (0.1d0,-0.5d0),
435  + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
436  + (0.7d0,-0.8d0)/
437  DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
438  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
439  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
440  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
441  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
442  + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (0.7d0,-0.8d0),
443  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
444  + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
445  + (-0.9d0,-0.4d0), (-0.1d0,-0.9d0),
446  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
447  + (0.0d0,0.0d0)/
448  DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
449  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
450  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
451  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
452  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
453  + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.9d0,0.5d0),
454  + (-0.4d0,-0.7d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
455  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
456  + (-0.9d0,0.5d0), (-0.4d0,-0.7d0), (0.1d0,-0.5d0),
457  + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
458  + (0.2d0,-0.8d0)/
459  DATA csize1/(0.0d0,0.0d0), (0.9d0,0.9d0),
460  + (1.63d0,1.73d0), (2.90d0,2.78d0)/
461  DATA csize3/(0.0d0,0.0d0), (0.0d0,0.0d0),
462  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
463  + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.17d0,1.17d0),
464  + (1.17d0,1.17d0), (1.17d0,1.17d0),
465  + (1.17d0,1.17d0), (1.17d0,1.17d0),
466  + (1.17d0,1.17d0), (1.17d0,1.17d0)/
467  DATA csize2/(0.0d0,0.0d0), (0.0d0,0.0d0),
468  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
469  + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.54d0,1.54d0),
470  + (1.54d0,1.54d0), (1.54d0,1.54d0),
471  + (1.54d0,1.54d0), (1.54d0,1.54d0),
472  + (1.54d0,1.54d0), (1.54d0,1.54d0)/
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 * .. ZDOTCTEST ..
492  CALL zdotctest(n,cx,incx,cy,incy,ztemp)
493  cdot(1) = ztemp
494  CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
495  ELSE IF (icase.EQ.2) THEN
496 * .. ZDOTUTEST ..
497  CALL zdotutest(n,cx,incx,cy,incy,ztemp)
498  cdot(1) = ztemp
499  CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
500  ELSE IF (icase.EQ.3) THEN
501 * .. ZAXPYTEST ..
502  CALL zaxpytest(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 * .. ZCOPYTEST ..
506  CALL zcopytest(n,cx,incx,cy,incy)
507  CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
508  ELSE IF (icase.EQ.5) THEN
509 * .. ZSWAPTEST ..
510  CALL zswaptest(n,cx,incx,cy,incy)
511  CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0d0)
512  CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
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  DOUBLE PRECISION SFAC
536  INTEGER LEN
537 * .. Array Arguments ..
538  DOUBLE PRECISION SCOMP(len), SSIZE(len), STRUE(len)
539 * .. Scalars in Common ..
540  INTEGER ICASE, INCX, INCY, MODE, N
541  LOGICAL PASS
542 * .. Local Scalars ..
543  DOUBLE PRECISION SD
544  INTEGER I
545 * .. External Functions ..
546  DOUBLE PRECISION 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.0d0)
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,2d36.8,2d12.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  DOUBLE PRECISION SCOMP1, SFAC, STRUE1
588 * .. Array Arguments ..
589  DOUBLE PRECISION SSIZE(*)
590 * .. Local Arrays ..
591  DOUBLE PRECISION 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  DOUBLE PRECISION FUNCTION sdiff(SA,SB)
603 * ********************************* SDIFF **************************
604 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
605 *
606 * .. Scalar Arguments ..
607  DOUBLE PRECISION 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  DOUBLE PRECISION SFAC
619  INTEGER LEN
620 * .. Array Arguments ..
621  COMPLEX*16 CCOMP(len), CSIZE(len), CTRUE(len)
622 * .. Local Scalars ..
623  INTEGER I
624 * .. Local Arrays ..
625  DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20)
626 * .. External Subroutines ..
627  EXTERNAL stest
628 * .. Intrinsic Functions ..
629  INTRINSIC dimag, dble
630 * .. Executable Statements ..
631  DO 20 i = 1, len
632  scomp(2*i-1) = dble(ccomp(i))
633  scomp(2*i) = dimag(ccomp(i))
634  strue(2*i-1) = dble(ctrue(i))
635  strue(2*i) = dimag(ctrue(i))
636  ssize(2*i-1) = dble(csize(i))
637  ssize(2*i) = dimag(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
zcblat1
program zcblat1
Definition: c_zblat1.f:1
itest1
subroutine itest1(ICOMP, ITRUE)
Definition: cblat1.f:686
check1
subroutine check1(SFAC)
Definition: cblat1.f:119
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