LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
zblat1.f
Go to the documentation of this file.
1 *> \brief \b ZBLAT1
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 ZBLAT1
12 *
13 *
14 *> \par Purpose:
15 * =============
16 *>
17 *> \verbatim
18 *>
19 *> Test program for the COMPLEX*16 Level 1 BLAS.
20 *>
21 *> Based upon the original BLAS test routine together with:
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 *> \date April 2012
34 *
35 *> \ingroup complex16_blas_testing
36 *
37 * =====================================================================
38  PROGRAM zblat1
39 *
40 * -- Reference BLAS test routine (version 3.4.1) --
41 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
42 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
43 * April 2012
44 *
45 * =====================================================================
46 *
47 * .. Parameters ..
48  INTEGER nout
49  parameter(nout=6)
50 * .. Scalars in Common ..
51  INTEGER icase, incx, incy, mode, n
52  LOGICAL pass
53 * .. Local Scalars ..
54  DOUBLE PRECISION sfac
55  INTEGER ic
56 * .. External Subroutines ..
57  EXTERNAL check1, check2, header
58 * .. Common blocks ..
59  common /combla/icase, n, incx, incy, mode, pass
60 * .. Data statements ..
61  DATA sfac/9.765625d-4/
62 * .. Executable Statements ..
63  WRITE (nout,99999)
64  DO 20 ic = 1, 10
65  icase = ic
66  CALL header
67 *
68 * Initialize PASS, INCX, INCY, and MODE for a new case.
69 * The value 9999 for INCX, INCY or MODE will appear in the
70 * detailed output, if any, for cases that do not involve
71 * these parameters.
72 *
73  pass = .true.
74  incx = 9999
75  incy = 9999
76  mode = 9999
77  IF (icase.LE.5) THEN
78  CALL check2(sfac)
79  ELSE IF (icase.GE.6) THEN
80  CALL check1(sfac)
81  END IF
82 * -- Print
83  IF (pass) WRITE (nout,99998)
84  20 continue
85  stop
86 *
87 99999 format(' Complex BLAS Test Program Results',/1x)
88 99998 format(' ----- PASS -----')
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)/'ZDOTC '/
103  DATA l(2)/'ZDOTU '/
104  DATA l(3)/'ZAXPY '/
105  DATA l(4)/'ZCOPY '/
106  DATA l(5)/'ZSWAP '/
107  DATA l(6)/'DZNRM2'/
108  DATA l(7)/'DZASUM'/
109  DATA l(8)/'ZSCAL '/
110  DATA l(9)/'ZDSCAL'/
111  DATA l(10)/'IZAMAX'/
112 * .. Executable Statements ..
113  WRITE (nout,99999) icase, l(icase)
114  return
115 *
116 99999 format(/' Test of subprogram number',i3,12x,a6)
117  END
118  SUBROUTINE check1(SFAC)
119 * .. Parameters ..
120  INTEGER nout
121  parameter(nout=6)
122 * .. Scalar Arguments ..
123  DOUBLE PRECISION sfac
124 * .. Scalars in Common ..
125  INTEGER icase, incx, incy, mode, n
126  LOGICAL pass
127 * .. Local Scalars ..
128  COMPLEX*16 ca
129  DOUBLE PRECISION sa
130  INTEGER i, j, len, np1
131 * .. Local Arrays ..
132  COMPLEX*16 ctrue5(8,5,2), ctrue6(8,5,2), cv(8,5,2), cx(8),
133  + mwpcs(5), mwpct(5)
134  DOUBLE PRECISION strue2(5), strue4(5)
135  INTEGER itrue3(5)
136 * .. External Functions ..
137  DOUBLE PRECISION dzasum, dznrm2
138  INTEGER izamax
139  EXTERNAL dzasum, dznrm2, izamax
140 * .. External Subroutines ..
141  EXTERNAL zscal, zdscal, ctest, itest1, stest1
142 * .. Intrinsic Functions ..
143  INTRINSIC max
144 * .. Common blocks ..
145  common /combla/icase, n, incx, incy, mode, pass
146 * .. Data statements ..
147  DATA sa, ca/0.3d0, (0.4d0,-0.7d0)/
148  DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
149  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
150  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
151  + (1.0d0,2.0d0), (0.3d0,-0.4d0), (3.0d0,4.0d0),
152  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
153  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
154  + (0.1d0,-0.3d0), (0.5d0,-0.1d0), (5.0d0,6.0d0),
155  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
156  + (5.0d0,6.0d0), (5.0d0,6.0d0), (0.1d0,0.1d0),
157  + (-0.6d0,0.1d0), (0.1d0,-0.3d0), (7.0d0,8.0d0),
158  + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
159  + (7.0d0,8.0d0), (0.3d0,0.1d0), (0.5d0,0.0d0),
160  + (0.0d0,0.5d0), (0.0d0,0.2d0), (2.0d0,3.0d0),
161  + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
162  DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
163  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
164  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
165  + (4.0d0,5.0d0), (0.3d0,-0.4d0), (6.0d0,7.0d0),
166  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
167  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
168  + (0.1d0,-0.3d0), (8.0d0,9.0d0), (0.5d0,-0.1d0),
169  + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
170  + (2.0d0,5.0d0), (2.0d0,5.0d0), (0.1d0,0.1d0),
171  + (3.0d0,6.0d0), (-0.6d0,0.1d0), (4.0d0,7.0d0),
172  + (0.1d0,-0.3d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
173  + (7.0d0,2.0d0), (0.3d0,0.1d0), (5.0d0,8.0d0),
174  + (0.5d0,0.0d0), (6.0d0,9.0d0), (0.0d0,0.5d0),
175  + (8.0d0,3.0d0), (0.0d0,0.2d0), (9.0d0,4.0d0)/
176  DATA strue2/0.0d0, 0.5d0, 0.6d0, 0.7d0, 0.8d0/
177  DATA strue4/0.0d0, 0.7d0, 1.0d0, 1.3d0, 1.6d0/
178  DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
179  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
180  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
181  + (1.0d0,2.0d0), (-0.16d0,-0.37d0), (3.0d0,4.0d0),
182  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
183  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
184  + (-0.17d0,-0.19d0), (0.13d0,-0.39d0),
185  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
186  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
187  + (0.11d0,-0.03d0), (-0.17d0,0.46d0),
188  + (-0.17d0,-0.19d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
189  + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
190  + (0.19d0,-0.17d0), (0.20d0,-0.35d0),
191  + (0.35d0,0.20d0), (0.14d0,0.08d0),
192  + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0),
193  + (2.0d0,3.0d0)/
194  DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
195  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
196  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
197  + (4.0d0,5.0d0), (-0.16d0,-0.37d0), (6.0d0,7.0d0),
198  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
199  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
200  + (-0.17d0,-0.19d0), (8.0d0,9.0d0),
201  + (0.13d0,-0.39d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
202  + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
203  + (0.11d0,-0.03d0), (3.0d0,6.0d0),
204  + (-0.17d0,0.46d0), (4.0d0,7.0d0),
205  + (-0.17d0,-0.19d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
206  + (7.0d0,2.0d0), (0.19d0,-0.17d0), (5.0d0,8.0d0),
207  + (0.20d0,-0.35d0), (6.0d0,9.0d0),
208  + (0.35d0,0.20d0), (8.0d0,3.0d0),
209  + (0.14d0,0.08d0), (9.0d0,4.0d0)/
210  DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
211  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
212  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
213  + (1.0d0,2.0d0), (0.09d0,-0.12d0), (3.0d0,4.0d0),
214  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
215  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
216  + (0.03d0,-0.09d0), (0.15d0,-0.03d0),
217  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
218  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
219  + (0.03d0,0.03d0), (-0.18d0,0.03d0),
220  + (0.03d0,-0.09d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
221  + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
222  + (0.09d0,0.03d0), (0.15d0,0.00d0),
223  + (0.00d0,0.15d0), (0.00d0,0.06d0), (2.0d0,3.0d0),
224  + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
225  DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
226  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
227  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
228  + (4.0d0,5.0d0), (0.09d0,-0.12d0), (6.0d0,7.0d0),
229  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
230  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
231  + (0.03d0,-0.09d0), (8.0d0,9.0d0),
232  + (0.15d0,-0.03d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
233  + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
234  + (0.03d0,0.03d0), (3.0d0,6.0d0),
235  + (-0.18d0,0.03d0), (4.0d0,7.0d0),
236  + (0.03d0,-0.09d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
237  + (7.0d0,2.0d0), (0.09d0,0.03d0), (5.0d0,8.0d0),
238  + (0.15d0,0.00d0), (6.0d0,9.0d0), (0.00d0,0.15d0),
239  + (8.0d0,3.0d0), (0.00d0,0.06d0), (9.0d0,4.0d0)/
240  DATA itrue3/0, 1, 2, 2, 2/
241 * .. Executable Statements ..
242  DO 60 incx = 1, 2
243  DO 40 np1 = 1, 5
244  n = np1 - 1
245  len = 2*max(n,1)
246 * .. Set vector arguments ..
247  DO 20 i = 1, len
248  cx(i) = cv(i,np1,incx)
249  20 continue
250  IF (icase.EQ.6) THEN
251 * .. DZNRM2 ..
252  CALL stest1(dznrm2(n,cx,incx),strue2(np1),strue2(np1),
253  + sfac)
254  ELSE IF (icase.EQ.7) THEN
255 * .. DZASUM ..
256  CALL stest1(dzasum(n,cx,incx),strue4(np1),strue4(np1),
257  + sfac)
258  ELSE IF (icase.EQ.8) THEN
259 * .. ZSCAL ..
260  CALL zscal(n,ca,cx,incx)
261  CALL ctest(len,cx,ctrue5(1,np1,incx),ctrue5(1,np1,incx),
262  + sfac)
263  ELSE IF (icase.EQ.9) THEN
264 * .. ZDSCAL ..
265  CALL zdscal(n,sa,cx,incx)
266  CALL ctest(len,cx,ctrue6(1,np1,incx),ctrue6(1,np1,incx),
267  + sfac)
268  ELSE IF (icase.EQ.10) THEN
269 * .. IZAMAX ..
270  CALL itest1(izamax(n,cx,incx),itrue3(np1))
271  ELSE
272  WRITE (nout,*) ' Shouldn''t be here in CHECK1'
273  stop
274  END IF
275 *
276  40 continue
277  60 continue
278 *
279  incx = 1
280  IF (icase.EQ.8) THEN
281 * ZSCAL
282 * Add a test for alpha equal to zero.
283  ca = (0.0d0,0.0d0)
284  DO 80 i = 1, 5
285  mwpct(i) = (0.0d0,0.0d0)
286  mwpcs(i) = (1.0d0,1.0d0)
287  80 continue
288  CALL zscal(5,ca,cx,incx)
289  CALL ctest(5,cx,mwpct,mwpcs,sfac)
290  ELSE IF (icase.EQ.9) THEN
291 * ZDSCAL
292 * Add a test for alpha equal to zero.
293  sa = 0.0d0
294  DO 100 i = 1, 5
295  mwpct(i) = (0.0d0,0.0d0)
296  mwpcs(i) = (1.0d0,1.0d0)
297  100 continue
298  CALL zdscal(5,sa,cx,incx)
299  CALL ctest(5,cx,mwpct,mwpcs,sfac)
300 * Add a test for alpha equal to one.
301  sa = 1.0d0
302  DO 120 i = 1, 5
303  mwpct(i) = cx(i)
304  mwpcs(i) = cx(i)
305  120 continue
306  CALL zdscal(5,sa,cx,incx)
307  CALL ctest(5,cx,mwpct,mwpcs,sfac)
308 * Add a test for alpha equal to minus one.
309  sa = -1.0d0
310  DO 140 i = 1, 5
311  mwpct(i) = -cx(i)
312  mwpcs(i) = -cx(i)
313  140 continue
314  CALL zdscal(5,sa,cx,incx)
315  CALL ctest(5,cx,mwpct,mwpcs,sfac)
316  END IF
317  return
318  END
319  SUBROUTINE check2(SFAC)
320 * .. Parameters ..
321  INTEGER nout
322  parameter(nout=6)
323 * .. Scalar Arguments ..
324  DOUBLE PRECISION sfac
325 * .. Scalars in Common ..
326  INTEGER icase, incx, incy, mode, n
327  LOGICAL pass
328 * .. Local Scalars ..
329  COMPLEX*16 ca
330  INTEGER i, j, ki, kn, ksize, lenx, leny, mx, my
331 * .. Local Arrays ..
332  COMPLEX*16 cdot(1), csize1(4), csize2(7,2), csize3(14),
333  + ct10x(7,4,4), ct10y(7,4,4), ct6(4,4), ct7(4,4),
334  + ct8(7,4,4), cx(7), cx1(7), cy(7), cy1(7)
335  INTEGER incxs(4), incys(4), lens(4,2), ns(4)
336 * .. External Functions ..
337  COMPLEX*16 zdotc, zdotu
338  EXTERNAL zdotc, zdotu
339 * .. External Subroutines ..
340  EXTERNAL zaxpy, zcopy, zswap, ctest
341 * .. Intrinsic Functions ..
342  INTRINSIC abs, min
343 * .. Common blocks ..
344  common /combla/icase, n, incx, incy, mode, pass
345 * .. Data statements ..
346  DATA ca/(0.4d0,-0.7d0)/
347  DATA incxs/1, 2, -2, -1/
348  DATA incys/1, -2, 1, -2/
349  DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
350  DATA ns/0, 1, 2, 4/
351  DATA cx1/(0.7d0,-0.8d0), (-0.4d0,-0.7d0),
352  + (-0.1d0,-0.9d0), (0.2d0,-0.8d0),
353  + (-0.9d0,-0.4d0), (0.1d0,0.4d0), (-0.6d0,0.6d0)/
354  DATA cy1/(0.6d0,-0.6d0), (-0.9d0,0.5d0),
355  + (0.7d0,-0.6d0), (0.1d0,-0.5d0), (-0.1d0,-0.2d0),
356  + (-0.5d0,-0.3d0), (0.8d0,-0.7d0)/
357  DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
358  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
359  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
360  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
361  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
362  + (0.0d0,0.0d0), (0.32d0,-1.41d0),
363  + (-1.55d0,0.5d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
364  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
365  + (0.32d0,-1.41d0), (-1.55d0,0.5d0),
366  + (0.03d0,-0.89d0), (-0.38d0,-0.96d0),
367  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
368  DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
369  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
370  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
371  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
372  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
373  + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
374  + (-0.9d0,0.5d0), (0.42d0,-1.41d0), (0.0d0,0.0d0),
375  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
376  + (0.78d0,0.06d0), (-0.9d0,0.5d0),
377  + (0.06d0,-0.13d0), (0.1d0,-0.5d0),
378  + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
379  + (0.52d0,-1.51d0)/
380  DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
381  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
382  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
383  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
384  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
385  + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
386  + (-1.18d0,-0.31d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
387  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
388  + (0.78d0,0.06d0), (-1.54d0,0.97d0),
389  + (0.03d0,-0.89d0), (-0.18d0,-1.31d0),
390  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
391  DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
392  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
393  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
394  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
395  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
396  + (0.0d0,0.0d0), (0.32d0,-1.41d0), (-0.9d0,0.5d0),
397  + (0.05d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
398  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.32d0,-1.41d0),
399  + (-0.9d0,0.5d0), (0.05d0,-0.6d0), (0.1d0,-0.5d0),
400  + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
401  + (0.32d0,-1.16d0)/
402  DATA ct7/(0.0d0,0.0d0), (-0.06d0,-0.90d0),
403  + (0.65d0,-0.47d0), (-0.34d0,-1.22d0),
404  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
405  + (-0.59d0,-1.46d0), (-1.04d0,-0.04d0),
406  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
407  + (-0.83d0,0.59d0), (0.07d0,-0.37d0),
408  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
409  + (-0.76d0,-1.15d0), (-1.33d0,-1.82d0)/
410  DATA ct6/(0.0d0,0.0d0), (0.90d0,0.06d0),
411  + (0.91d0,-0.77d0), (1.80d0,-0.10d0),
412  + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.45d0,0.74d0),
413  + (0.20d0,0.90d0), (0.0d0,0.0d0), (0.90d0,0.06d0),
414  + (-0.55d0,0.23d0), (0.83d0,-0.39d0),
415  + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.04d0,0.79d0),
416  + (1.95d0,1.22d0)/
417  DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7d0,-0.8d0),
418  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
419  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
420  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
421  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
422  + (0.0d0,0.0d0), (0.6d0,-0.6d0), (-0.9d0,0.5d0),
423  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
424  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
425  + (-0.9d0,0.5d0), (0.7d0,-0.6d0), (0.1d0,-0.5d0),
426  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
427  DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7d0,-0.8d0),
428  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
429  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
430  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
431  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
432  + (0.0d0,0.0d0), (0.7d0,-0.6d0), (-0.4d0,-0.7d0),
433  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
434  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.8d0,-0.7d0),
435  + (-0.4d0,-0.7d0), (-0.1d0,-0.2d0),
436  + (0.2d0,-0.8d0), (0.7d0,-0.6d0), (0.1d0,0.4d0),
437  + (0.6d0,-0.6d0)/
438  DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7d0,-0.8d0),
439  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
440  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
441  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
442  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
443  + (0.0d0,0.0d0), (-0.9d0,0.5d0), (-0.4d0,-0.7d0),
444  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
445  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.1d0,-0.5d0),
446  + (-0.4d0,-0.7d0), (0.7d0,-0.6d0), (0.2d0,-0.8d0),
447  + (-0.9d0,0.5d0), (0.1d0,0.4d0), (0.6d0,-0.6d0)/
448  DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7d0,-0.8d0),
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.6d0,-0.6d0), (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.6d0,-0.6d0), (0.7d0,-0.6d0),
454  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
455  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
456  + (0.7d0,-0.6d0), (-0.1d0,-0.2d0), (0.8d0,-0.7d0),
457  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
458  DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
459  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
460  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
461  + (0.7d0,-0.8d0), (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.7d0,-0.8d0), (-0.4d0,-0.7d0),
464  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
465  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
466  + (-0.4d0,-0.7d0), (-0.1d0,-0.9d0),
467  + (0.2d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
468  + (0.0d0,0.0d0)/
469  DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
470  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
471  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
472  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
473  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
474  + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (-0.9d0,0.5d0),
475  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
476  + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
477  + (-0.9d0,0.5d0), (-0.9d0,-0.4d0), (0.1d0,-0.5d0),
478  + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
479  + (0.7d0,-0.8d0)/
480  DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
481  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
482  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
483  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
484  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
485  + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (0.7d0,-0.8d0),
486  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
487  + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
488  + (-0.9d0,-0.4d0), (-0.1d0,-0.9d0),
489  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
490  + (0.0d0,0.0d0)/
491  DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
492  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
493  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
494  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
495  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
496  + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.9d0,0.5d0),
497  + (-0.4d0,-0.7d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
498  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
499  + (-0.9d0,0.5d0), (-0.4d0,-0.7d0), (0.1d0,-0.5d0),
500  + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
501  + (0.2d0,-0.8d0)/
502  DATA csize1/(0.0d0,0.0d0), (0.9d0,0.9d0),
503  + (1.63d0,1.73d0), (2.90d0,2.78d0)/
504  DATA csize3/(0.0d0,0.0d0), (0.0d0,0.0d0),
505  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
506  + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.17d0,1.17d0),
507  + (1.17d0,1.17d0), (1.17d0,1.17d0),
508  + (1.17d0,1.17d0), (1.17d0,1.17d0),
509  + (1.17d0,1.17d0), (1.17d0,1.17d0)/
510  DATA csize2/(0.0d0,0.0d0), (0.0d0,0.0d0),
511  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
512  + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.54d0,1.54d0),
513  + (1.54d0,1.54d0), (1.54d0,1.54d0),
514  + (1.54d0,1.54d0), (1.54d0,1.54d0),
515  + (1.54d0,1.54d0), (1.54d0,1.54d0)/
516 * .. Executable Statements ..
517  DO 60 ki = 1, 4
518  incx = incxs(ki)
519  incy = incys(ki)
520  mx = abs(incx)
521  my = abs(incy)
522 *
523  DO 40 kn = 1, 4
524  n = ns(kn)
525  ksize = min(2,kn)
526  lenx = lens(kn,mx)
527  leny = lens(kn,my)
528 * .. initialize all argument arrays ..
529  DO 20 i = 1, 7
530  cx(i) = cx1(i)
531  cy(i) = cy1(i)
532  20 continue
533  IF (icase.EQ.1) THEN
534 * .. ZDOTC ..
535  cdot(1) = zdotc(n,cx,incx,cy,incy)
536  CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
537  ELSE IF (icase.EQ.2) THEN
538 * .. ZDOTU ..
539  cdot(1) = zdotu(n,cx,incx,cy,incy)
540  CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
541  ELSE IF (icase.EQ.3) THEN
542 * .. ZAXPY ..
543  CALL zaxpy(n,ca,cx,incx,cy,incy)
544  CALL ctest(leny,cy,ct8(1,kn,ki),csize2(1,ksize),sfac)
545  ELSE IF (icase.EQ.4) THEN
546 * .. ZCOPY ..
547  CALL zcopy(n,cx,incx,cy,incy)
548  CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
549  ELSE IF (icase.EQ.5) THEN
550 * .. ZSWAP ..
551  CALL zswap(n,cx,incx,cy,incy)
552  CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0d0)
553  CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
554  ELSE
555  WRITE (nout,*) ' Shouldn''t be here in CHECK2'
556  stop
557  END IF
558 *
559  40 continue
560  60 continue
561  return
562  END
563  SUBROUTINE stest(LEN,SCOMP,STRUE,SSIZE,SFAC)
564 * ********************************* STEST **************************
565 *
566 * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
567 * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
568 * NEGLIGIBLE.
569 *
570 * C. L. LAWSON, JPL, 1974 DEC 10
571 *
572 * .. Parameters ..
573  INTEGER nout
574  DOUBLE PRECISION zero
575  parameter(nout=6, zero=0.0d0)
576 * .. Scalar Arguments ..
577  DOUBLE PRECISION sfac
578  INTEGER len
579 * .. Array Arguments ..
580  DOUBLE PRECISION scomp(len), ssize(len), strue(len)
581 * .. Scalars in Common ..
582  INTEGER icase, incx, incy, mode, n
583  LOGICAL pass
584 * .. Local Scalars ..
585  DOUBLE PRECISION sd
586  INTEGER i
587 * .. External Functions ..
588  DOUBLE PRECISION sdiff
589  EXTERNAL sdiff
590 * .. Intrinsic Functions ..
591  INTRINSIC abs
592 * .. Common blocks ..
593  common /combla/icase, n, incx, incy, mode, pass
594 * .. Executable Statements ..
595 *
596  DO 40 i = 1, len
597  sd = scomp(i) - strue(i)
598  IF (abs(sfac*sd) .LE. abs(ssize(i))*epsilon(zero))
599  + go to 40
600 *
601 * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
602 *
603  IF ( .NOT. pass) go to 20
604 * PRINT FAIL MESSAGE AND HEADER.
605  pass = .false.
606  WRITE (nout,99999)
607  WRITE (nout,99998)
608  20 WRITE (nout,99997) icase, n, incx, incy, mode, i, scomp(i),
609  + strue(i), sd, ssize(i)
610  40 continue
611  return
612 *
613 99999 format(' FAIL')
614 99998 format(/' CASE N INCX INCY MODE I ',
615  + ' COMP(I) TRUE(I) DIFFERENCE',
616  + ' SIZE(I)',/1x)
617 99997 format(1x,i4,i3,3i5,i3,2d36.8,2d12.4)
618  END
619  SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
620 * ************************* STEST1 *****************************
621 *
622 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
623 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
624 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
625 *
626 * C.L. LAWSON, JPL, 1978 DEC 6
627 *
628 * .. Scalar Arguments ..
629  DOUBLE PRECISION scomp1, sfac, strue1
630 * .. Array Arguments ..
631  DOUBLE PRECISION ssize(*)
632 * .. Local Arrays ..
633  DOUBLE PRECISION scomp(1), strue(1)
634 * .. External Subroutines ..
635  EXTERNAL stest
636 * .. Executable Statements ..
637 *
638  scomp(1) = scomp1
639  strue(1) = strue1
640  CALL stest(1,scomp,strue,ssize,sfac)
641 *
642  return
643  END
644  DOUBLE PRECISION FUNCTION sdiff(SA,SB)
645 * ********************************* SDIFF **************************
646 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
647 *
648 * .. Scalar Arguments ..
649  DOUBLE PRECISION sa, sb
650 * .. Executable Statements ..
651  sdiff = sa - sb
652  return
653  END
654  SUBROUTINE ctest(LEN,CCOMP,CTRUE,CSIZE,SFAC)
655 * **************************** CTEST *****************************
656 *
657 * C.L. LAWSON, JPL, 1978 DEC 6
658 *
659 * .. Scalar Arguments ..
660  DOUBLE PRECISION sfac
661  INTEGER len
662 * .. Array Arguments ..
663  COMPLEX*16 ccomp(len), csize(len), ctrue(len)
664 * .. Local Scalars ..
665  INTEGER i
666 * .. Local Arrays ..
667  DOUBLE PRECISION scomp(20), ssize(20), strue(20)
668 * .. External Subroutines ..
669  EXTERNAL stest
670 * .. Intrinsic Functions ..
671  INTRINSIC dimag, dble
672 * .. Executable Statements ..
673  DO 20 i = 1, len
674  scomp(2*i-1) = dble(ccomp(i))
675  scomp(2*i) = dimag(ccomp(i))
676  strue(2*i-1) = dble(ctrue(i))
677  strue(2*i) = dimag(ctrue(i))
678  ssize(2*i-1) = dble(csize(i))
679  ssize(2*i) = dimag(csize(i))
680  20 continue
681 *
682  CALL stest(2*len,scomp,strue,ssize,sfac)
683  return
684  END
685  SUBROUTINE itest1(ICOMP,ITRUE)
686 * ********************************* ITEST1 *************************
687 *
688 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
689 * EQUALITY.
690 * C. L. LAWSON, JPL, 1974 DEC 10
691 *
692 * .. Parameters ..
693  INTEGER nout
694  parameter(nout=6)
695 * .. Scalar Arguments ..
696  INTEGER icomp, itrue
697 * .. Scalars in Common ..
698  INTEGER icase, incx, incy, mode, n
699  LOGICAL pass
700 * .. Local Scalars ..
701  INTEGER id
702 * .. Common blocks ..
703  common /combla/icase, n, incx, incy, mode, pass
704 * .. Executable Statements ..
705  IF (icomp.EQ.itrue) go to 40
706 *
707 * HERE ICOMP IS NOT EQUAL TO ITRUE.
708 *
709  IF ( .NOT. pass) go to 20
710 * PRINT FAIL MESSAGE AND HEADER.
711  pass = .false.
712  WRITE (nout,99999)
713  WRITE (nout,99998)
714  20 id = icomp - itrue
715  WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
716  40 continue
717  return
718 *
719 99999 format(' FAIL')
720 99998 format(/' CASE N INCX INCY MODE ',
721  + ' COMP TRUE DIFFERENCE',
722  + /1x)
723 99997 format(1x,i4,i3,3i5,2i36,i12)
724  END