LAPACK  3.9.1
LAPACK: Linear Algebra PACKage
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 *> \ingroup complex16_blas_testing
34 *
35 * =====================================================================
36  PROGRAM zblat1
37 *
38 * -- Reference BLAS test routine --
39 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
40 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
41 *
42 * =====================================================================
43 *
44 * .. Parameters ..
45  INTEGER nout
46  parameter(nout=6)
47 * .. Scalars in Common ..
48  INTEGER icase, incx, incy, mode, n
49  LOGICAL pass
50 * .. Local Scalars ..
51  DOUBLE PRECISION sfac
52  INTEGER ic
53 * .. External Subroutines ..
54  EXTERNAL check1, check2, header
55 * .. Common blocks ..
56  COMMON /combla/icase, n, incx, incy, mode, pass
57 * .. Data statements ..
58  DATA sfac/9.765625d-4/
59 * .. Executable Statements ..
60  WRITE (nout,99999)
61  DO 20 ic = 1, 10
62  icase = ic
63  CALL header
64 *
65 * Initialize PASS, INCX, INCY, and MODE for a new case.
66 * The value 9999 for INCX, INCY or MODE will appear in the
67 * detailed output, if any, for cases that do not involve
68 * these parameters.
69 *
70  pass = .true.
71  incx = 9999
72  incy = 9999
73  mode = 9999
74  IF (icase.LE.5) THEN
75  CALL check2(sfac)
76  ELSE IF (icase.GE.6) THEN
77  CALL check1(sfac)
78  END IF
79 * -- Print
80  IF (pass) WRITE (nout,99998)
81  20 CONTINUE
82  stop
83 *
84 99999 FORMAT (' Complex BLAS Test Program Results',/1x)
85 99998 FORMAT (' ----- PASS -----')
86  END
87  SUBROUTINE header
88 * .. Parameters ..
89  INTEGER NOUT
90  parameter(nout=6)
91 * .. Scalars in Common ..
92  INTEGER ICASE, INCX, INCY, MODE, N
93  LOGICAL PASS
94 * .. Local Arrays ..
95  CHARACTER*6 L(10)
96 * .. Common blocks ..
97  COMMON /combla/icase, n, incx, incy, mode, pass
98 * .. Data statements ..
99  DATA l(1)/'ZDOTC '/
100  DATA l(2)/'ZDOTU '/
101  DATA l(3)/'ZAXPY '/
102  DATA l(4)/'ZCOPY '/
103  DATA l(5)/'ZSWAP '/
104  DATA l(6)/'DZNRM2'/
105  DATA l(7)/'DZASUM'/
106  DATA l(8)/'ZSCAL '/
107  DATA l(9)/'ZDSCAL'/
108  DATA l(10)/'IZAMAX'/
109 * .. Executable Statements ..
110  WRITE (nout,99999) icase, l(icase)
111  RETURN
112 *
113 99999 FORMAT (/' Test of subprogram number',i3,12x,a6)
114  END
115  SUBROUTINE check1(SFAC)
116 * .. Parameters ..
117  INTEGER NOUT
118  parameter(nout=6)
119 * .. Scalar Arguments ..
120  DOUBLE PRECISION SFAC
121 * .. Scalars in Common ..
122  INTEGER ICASE, INCX, INCY, MODE, N
123  LOGICAL PASS
124 * .. Local Scalars ..
125  COMPLEX*16 CA
126  DOUBLE PRECISION SA
127  INTEGER I, IX, J, LEN, NP1
128 * .. Local Arrays ..
129  COMPLEX*16 CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CVR(8),
130  + CX(8), CXR(15), MWPCS(5), MWPCT(5)
131  DOUBLE PRECISION STRUE2(5), STRUE4(5)
132  INTEGER ITRUE3(5), ITRUEC(5)
133 * .. External Functions ..
134  DOUBLE PRECISION DZASUM, DZNRM2
135  INTEGER IZAMAX
136  EXTERNAL dzasum, dznrm2, izamax
137 * .. External Subroutines ..
138  EXTERNAL zscal, zdscal, ctest, itest1, stest1
139 * .. Intrinsic Functions ..
140  INTRINSIC max
141 * .. Common blocks ..
142  COMMON /combla/icase, n, incx, incy, mode, pass
143 * .. Data statements ..
144  DATA sa, ca/0.3d0, (0.4d0,-0.7d0)/
145  DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
146  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
147  + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
148  + (1.0d0,2.0d0), (0.3d0,-0.4d0), (3.0d0,4.0d0),
149  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
150  + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
151  + (0.1d0,-0.3d0), (0.5d0,-0.1d0), (5.0d0,6.0d0),
152  + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
153  + (5.0d0,6.0d0), (5.0d0,6.0d0), (0.1d0,0.1d0),
154  + (-0.6d0,0.1d0), (0.1d0,-0.3d0), (7.0d0,8.0d0),
155  + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
156  + (7.0d0,8.0d0), (0.3d0,0.1d0), (0.5d0,0.0d0),
157  + (0.0d0,0.5d0), (0.0d0,0.2d0), (2.0d0,3.0d0),
158  + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
159  DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
160  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
161  + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
162  + (4.0d0,5.0d0), (0.3d0,-0.4d0), (6.0d0,7.0d0),
163  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
164  + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
165  + (0.1d0,-0.3d0), (8.0d0,9.0d0), (0.5d0,-0.1d0),
166  + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
167  + (2.0d0,5.0d0), (2.0d0,5.0d0), (0.1d0,0.1d0),
168  + (3.0d0,6.0d0), (-0.6d0,0.1d0), (4.0d0,7.0d0),
169  + (0.1d0,-0.3d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
170  + (7.0d0,2.0d0), (0.3d0,0.1d0), (5.0d0,8.0d0),
171  + (0.5d0,0.0d0), (6.0d0,9.0d0), (0.0d0,0.5d0),
172  + (8.0d0,3.0d0), (0.0d0,0.2d0), (9.0d0,4.0d0)/
173  DATA cvr/(8.0d0,8.0d0), (-7.0d0,-7.0d0),
174  + (9.0d0,9.0d0), (5.0d0,5.0d0), (9.0d0,9.0d0),
175  + (8.0d0,8.0d0), (7.0d0,7.0d0), (7.0d0,7.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  DATA itruec/0, 1, 1, 1, 1/
242 * .. Executable Statements ..
243  DO 60 incx = 1, 2
244  DO 40 np1 = 1, 5
245  n = np1 - 1
246  len = 2*max(n,1)
247 * .. Set vector arguments ..
248  DO 20 i = 1, len
249  cx(i) = cv(i,np1,incx)
250  20 CONTINUE
251  IF (icase.EQ.6) THEN
252 * .. DZNRM2 ..
253  CALL stest1(dznrm2(n,cx,incx),strue2(np1),strue2(np1),
254  + sfac)
255  ELSE IF (icase.EQ.7) THEN
256 * .. DZASUM ..
257  CALL stest1(dzasum(n,cx,incx),strue4(np1),strue4(np1),
258  + sfac)
259  ELSE IF (icase.EQ.8) THEN
260 * .. ZSCAL ..
261  CALL zscal(n,ca,cx,incx)
262  CALL ctest(len,cx,ctrue5(1,np1,incx),ctrue5(1,np1,incx),
263  + sfac)
264  ELSE IF (icase.EQ.9) THEN
265 * .. ZDSCAL ..
266  CALL zdscal(n,sa,cx,incx)
267  CALL ctest(len,cx,ctrue6(1,np1,incx),ctrue6(1,np1,incx),
268  + sfac)
269  ELSE IF (icase.EQ.10) THEN
270 * .. IZAMAX ..
271  CALL itest1(izamax(n,cx,incx),itrue3(np1))
272  DO 160 i = 1, len
273  cx(i) = (42.0d0,43.0d0)
274  160 CONTINUE
275  CALL itest1(izamax(n,cx,incx),itruec(np1))
276  ELSE
277  WRITE (nout,*) ' Shouldn''t be here in CHECK1'
278  stop
279  END IF
280 *
281  40 CONTINUE
282  IF (icase.EQ.10) THEN
283  n = 8
284  ix = 1
285  DO 180 i = 1, n
286  cxr(ix) = cvr(i)
287  ix = ix + incx
288  180 CONTINUE
289  CALL itest1(izamax(n,cxr,incx),3)
290  END IF
291  60 CONTINUE
292 *
293  incx = 1
294  IF (icase.EQ.8) THEN
295 * ZSCAL
296 * Add a test for alpha equal to zero.
297  ca = (0.0d0,0.0d0)
298  DO 80 i = 1, 5
299  mwpct(i) = (0.0d0,0.0d0)
300  mwpcs(i) = (1.0d0,1.0d0)
301  80 CONTINUE
302  CALL zscal(5,ca,cx,incx)
303  CALL ctest(5,cx,mwpct,mwpcs,sfac)
304  ELSE IF (icase.EQ.9) THEN
305 * ZDSCAL
306 * Add a test for alpha equal to zero.
307  sa = 0.0d0
308  DO 100 i = 1, 5
309  mwpct(i) = (0.0d0,0.0d0)
310  mwpcs(i) = (1.0d0,1.0d0)
311  100 CONTINUE
312  CALL zdscal(5,sa,cx,incx)
313  CALL ctest(5,cx,mwpct,mwpcs,sfac)
314 * Add a test for alpha equal to one.
315  sa = 1.0d0
316  DO 120 i = 1, 5
317  mwpct(i) = cx(i)
318  mwpcs(i) = cx(i)
319  120 CONTINUE
320  CALL zdscal(5,sa,cx,incx)
321  CALL ctest(5,cx,mwpct,mwpcs,sfac)
322 * Add a test for alpha equal to minus one.
323  sa = -1.0d0
324  DO 140 i = 1, 5
325  mwpct(i) = -cx(i)
326  mwpcs(i) = -cx(i)
327  140 CONTINUE
328  CALL zdscal(5,sa,cx,incx)
329  CALL ctest(5,cx,mwpct,mwpcs,sfac)
330  END IF
331  RETURN
332  END
333  SUBROUTINE check2(SFAC)
334 * .. Parameters ..
335  INTEGER NOUT
336  parameter(nout=6)
337 * .. Scalar Arguments ..
338  DOUBLE PRECISION SFAC
339 * .. Scalars in Common ..
340  INTEGER ICASE, INCX, INCY, MODE, N
341  LOGICAL PASS
342 * .. Local Scalars ..
343  COMPLEX*16 CA
344  INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
345  + MX, MY
346 * .. Local Arrays ..
347  COMPLEX*16 CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
348  + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
349  + CT8(7,4,4), CTY0(1), CX(7), CX0(1), CX1(7),
350  + CY(7), CY0(1), CY1(7)
351  INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
352 * .. External Functions ..
353  COMPLEX*16 ZDOTC, ZDOTU
354  EXTERNAL zdotc, zdotu
355 * .. External Subroutines ..
356  EXTERNAL zaxpy, zcopy, zswap, ctest
357 * .. Intrinsic Functions ..
358  INTRINSIC abs, min
359 * .. Common blocks ..
360  COMMON /combla/icase, n, incx, incy, mode, pass
361 * .. Data statements ..
362  DATA ca/(0.4d0,-0.7d0)/
363  DATA incxs/1, 2, -2, -1/
364  DATA incys/1, -2, 1, -2/
365  DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
366  DATA ns/0, 1, 2, 4/
367  DATA cx1/(0.7d0,-0.8d0), (-0.4d0,-0.7d0),
368  + (-0.1d0,-0.9d0), (0.2d0,-0.8d0),
369  + (-0.9d0,-0.4d0), (0.1d0,0.4d0), (-0.6d0,0.6d0)/
370  DATA cy1/(0.6d0,-0.6d0), (-0.9d0,0.5d0),
371  + (0.7d0,-0.6d0), (0.1d0,-0.5d0), (-0.1d0,-0.2d0),
372  + (-0.5d0,-0.3d0), (0.8d0,-0.7d0)/
373  DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
374  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
375  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
376  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
377  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
378  + (0.0d0,0.0d0), (0.32d0,-1.41d0),
379  + (-1.55d0,0.5d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
380  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
381  + (0.32d0,-1.41d0), (-1.55d0,0.5d0),
382  + (0.03d0,-0.89d0), (-0.38d0,-0.96d0),
383  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
384  DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
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.32d0,-1.41d0), (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.07d0,-0.89d0),
390  + (-0.9d0,0.5d0), (0.42d0,-1.41d0), (0.0d0,0.0d0),
391  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
392  + (0.78d0,0.06d0), (-0.9d0,0.5d0),
393  + (0.06d0,-0.13d0), (0.1d0,-0.5d0),
394  + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
395  + (0.52d0,-1.51d0)/
396  DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
397  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
398  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
399  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
400  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
401  + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
402  + (-1.18d0,-0.31d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
403  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
404  + (0.78d0,0.06d0), (-1.54d0,0.97d0),
405  + (0.03d0,-0.89d0), (-0.18d0,-1.31d0),
406  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
407  DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
408  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
409  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
410  + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
411  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
412  + (0.0d0,0.0d0), (0.32d0,-1.41d0), (-0.9d0,0.5d0),
413  + (0.05d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
414  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.32d0,-1.41d0),
415  + (-0.9d0,0.5d0), (0.05d0,-0.6d0), (0.1d0,-0.5d0),
416  + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
417  + (0.32d0,-1.16d0)/
418  DATA ct7/(0.0d0,0.0d0), (-0.06d0,-0.90d0),
419  + (0.65d0,-0.47d0), (-0.34d0,-1.22d0),
420  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
421  + (-0.59d0,-1.46d0), (-1.04d0,-0.04d0),
422  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
423  + (-0.83d0,0.59d0), (0.07d0,-0.37d0),
424  + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
425  + (-0.76d0,-1.15d0), (-1.33d0,-1.82d0)/
426  DATA ct6/(0.0d0,0.0d0), (0.90d0,0.06d0),
427  + (0.91d0,-0.77d0), (1.80d0,-0.10d0),
428  + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.45d0,0.74d0),
429  + (0.20d0,0.90d0), (0.0d0,0.0d0), (0.90d0,0.06d0),
430  + (-0.55d0,0.23d0), (0.83d0,-0.39d0),
431  + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.04d0,0.79d0),
432  + (1.95d0,1.22d0)/
433  DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7d0,-0.8d0),
434  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
435  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
436  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
437  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
438  + (0.0d0,0.0d0), (0.6d0,-0.6d0), (-0.9d0,0.5d0),
439  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
440  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
441  + (-0.9d0,0.5d0), (0.7d0,-0.6d0), (0.1d0,-0.5d0),
442  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
443  DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7d0,-0.8d0),
444  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
445  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
446  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
447  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
448  + (0.0d0,0.0d0), (0.7d0,-0.6d0), (-0.4d0,-0.7d0),
449  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
450  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.8d0,-0.7d0),
451  + (-0.4d0,-0.7d0), (-0.1d0,-0.2d0),
452  + (0.2d0,-0.8d0), (0.7d0,-0.6d0), (0.1d0,0.4d0),
453  + (0.6d0,-0.6d0)/
454  DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7d0,-0.8d0),
455  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
456  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
457  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
458  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
459  + (0.0d0,0.0d0), (-0.9d0,0.5d0), (-0.4d0,-0.7d0),
460  + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
461  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.1d0,-0.5d0),
462  + (-0.4d0,-0.7d0), (0.7d0,-0.6d0), (0.2d0,-0.8d0),
463  + (-0.9d0,0.5d0), (0.1d0,0.4d0), (0.6d0,-0.6d0)/
464  DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7d0,-0.8d0),
465  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
466  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
467  + (0.6d0,-0.6d0), (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.6d0,-0.6d0), (0.7d0,-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.6d0,-0.6d0),
472  + (0.7d0,-0.6d0), (-0.1d0,-0.2d0), (0.8d0,-0.7d0),
473  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
474  DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
475  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
476  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
477  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
478  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
479  + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.4d0,-0.7d0),
480  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
481  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
482  + (-0.4d0,-0.7d0), (-0.1d0,-0.9d0),
483  + (0.2d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
484  + (0.0d0,0.0d0)/
485  DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
486  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
487  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
488  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
489  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
490  + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (-0.9d0,0.5d0),
491  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
492  + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
493  + (-0.9d0,0.5d0), (-0.9d0,-0.4d0), (0.1d0,-0.5d0),
494  + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
495  + (0.7d0,-0.8d0)/
496  DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
497  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
498  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
499  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
500  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
501  + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (0.7d0,-0.8d0),
502  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
503  + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
504  + (-0.9d0,-0.4d0), (-0.1d0,-0.9d0),
505  + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
506  + (0.0d0,0.0d0)/
507  DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
508  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
509  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
510  + (0.7d0,-0.8d0), (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.7d0,-0.8d0), (-0.9d0,0.5d0),
513  + (-0.4d0,-0.7d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
514  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
515  + (-0.9d0,0.5d0), (-0.4d0,-0.7d0), (0.1d0,-0.5d0),
516  + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
517  + (0.2d0,-0.8d0)/
518  DATA csize1/(0.0d0,0.0d0), (0.9d0,0.9d0),
519  + (1.63d0,1.73d0), (2.90d0,2.78d0)/
520  DATA csize3/(0.0d0,0.0d0), (0.0d0,0.0d0),
521  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
522  + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.17d0,1.17d0),
523  + (1.17d0,1.17d0), (1.17d0,1.17d0),
524  + (1.17d0,1.17d0), (1.17d0,1.17d0),
525  + (1.17d0,1.17d0), (1.17d0,1.17d0)/
526  DATA csize2/(0.0d0,0.0d0), (0.0d0,0.0d0),
527  + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
528  + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.54d0,1.54d0),
529  + (1.54d0,1.54d0), (1.54d0,1.54d0),
530  + (1.54d0,1.54d0), (1.54d0,1.54d0),
531  + (1.54d0,1.54d0), (1.54d0,1.54d0)/
532 * .. Executable Statements ..
533  DO 60 ki = 1, 4
534  incx = incxs(ki)
535  incy = incys(ki)
536  mx = abs(incx)
537  my = abs(incy)
538 *
539  DO 40 kn = 1, 4
540  n = ns(kn)
541  ksize = min(2,kn)
542  lenx = lens(kn,mx)
543  leny = lens(kn,my)
544 * .. initialize all argument arrays ..
545  DO 20 i = 1, 7
546  cx(i) = cx1(i)
547  cy(i) = cy1(i)
548  20 CONTINUE
549  IF (icase.EQ.1) THEN
550 * .. ZDOTC ..
551  cdot(1) = zdotc(n,cx,incx,cy,incy)
552  CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
553  ELSE IF (icase.EQ.2) THEN
554 * .. ZDOTU ..
555  cdot(1) = zdotu(n,cx,incx,cy,incy)
556  CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
557  ELSE IF (icase.EQ.3) THEN
558 * .. ZAXPY ..
559  CALL zaxpy(n,ca,cx,incx,cy,incy)
560  CALL ctest(leny,cy,ct8(1,kn,ki),csize2(1,ksize),sfac)
561  ELSE IF (icase.EQ.4) THEN
562 * .. ZCOPY ..
563  CALL zcopy(n,cx,incx,cy,incy)
564  CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
565  IF (ki.EQ.1) THEN
566  cx0(1) = (42.0d0,43.0d0)
567  cy0(1) = (44.0d0,45.0d0)
568  IF (n.EQ.0) THEN
569  cty0(1) = cy0(1)
570  ELSE
571  cty0(1) = cx0(1)
572  END IF
573  lincx = incx
574  incx = 0
575  lincy = incy
576  incy = 0
577  CALL zcopy(n,cx0,incx,cy0,incy)
578  CALL ctest(1,cy0,cty0,csize3,1.0d0)
579  incx = lincx
580  incy = lincy
581  END IF
582  ELSE IF (icase.EQ.5) THEN
583 * .. ZSWAP ..
584  CALL zswap(n,cx,incx,cy,incy)
585  CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0d0)
586  CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
587  ELSE
588  WRITE (nout,*) ' Shouldn''t be here in CHECK2'
589  stop
590  END IF
591 *
592  40 CONTINUE
593  60 CONTINUE
594  RETURN
595  END
596  SUBROUTINE stest(LEN,SCOMP,STRUE,SSIZE,SFAC)
597 * ********************************* STEST **************************
598 *
599 * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
600 * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
601 * NEGLIGIBLE.
602 *
603 * C. L. LAWSON, JPL, 1974 DEC 10
604 *
605 * .. Parameters ..
606  INTEGER NOUT
607  DOUBLE PRECISION ZERO
608  parameter(nout=6, zero=0.0d0)
609 * .. Scalar Arguments ..
610  DOUBLE PRECISION SFAC
611  INTEGER LEN
612 * .. Array Arguments ..
613  DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
614 * .. Scalars in Common ..
615  INTEGER ICASE, INCX, INCY, MODE, N
616  LOGICAL PASS
617 * .. Local Scalars ..
618  DOUBLE PRECISION SD
619  INTEGER I
620 * .. External Functions ..
621  DOUBLE PRECISION SDIFF
622  EXTERNAL sdiff
623 * .. Intrinsic Functions ..
624  INTRINSIC abs
625 * .. Common blocks ..
626  COMMON /combla/icase, n, incx, incy, mode, pass
627 * .. Executable Statements ..
628 *
629  DO 40 i = 1, len
630  sd = scomp(i) - strue(i)
631  IF (abs(sfac*sd) .LE. abs(ssize(i))*epsilon(zero))
632  + GO TO 40
633 *
634 * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
635 *
636  IF ( .NOT. pass) GO TO 20
637 * PRINT FAIL MESSAGE AND HEADER.
638  pass = .false.
639  WRITE (nout,99999)
640  WRITE (nout,99998)
641  20 WRITE (nout,99997) icase, n, incx, incy, mode, i, scomp(i),
642  + strue(i), sd, ssize(i)
643  40 CONTINUE
644  RETURN
645 *
646 99999 FORMAT (' FAIL')
647 99998 FORMAT (/' CASE N INCX INCY MODE I ',
648  + ' COMP(I) TRUE(I) DIFFERENCE',
649  + ' SIZE(I)',/1x)
650 99997 FORMAT (1x,i4,i3,3i5,i3,2d36.8,2d12.4)
651  END
652  SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
653 * ************************* STEST1 *****************************
654 *
655 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
656 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
657 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
658 *
659 * C.L. LAWSON, JPL, 1978 DEC 6
660 *
661 * .. Scalar Arguments ..
662  DOUBLE PRECISION SCOMP1, SFAC, STRUE1
663 * .. Array Arguments ..
664  DOUBLE PRECISION SSIZE(*)
665 * .. Local Arrays ..
666  DOUBLE PRECISION SCOMP(1), STRUE(1)
667 * .. External Subroutines ..
668  EXTERNAL stest
669 * .. Executable Statements ..
670 *
671  scomp(1) = scomp1
672  strue(1) = strue1
673  CALL stest(1,scomp,strue,ssize,sfac)
674 *
675  RETURN
676  END
677  DOUBLE PRECISION FUNCTION sdiff(SA,SB)
678 * ********************************* SDIFF **************************
679 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
680 *
681 * .. Scalar Arguments ..
682  DOUBLE PRECISION sa, sb
683 * .. Executable Statements ..
684  sdiff = sa - sb
685  RETURN
686  END
687  SUBROUTINE ctest(LEN,CCOMP,CTRUE,CSIZE,SFAC)
688 * **************************** CTEST *****************************
689 *
690 * C.L. LAWSON, JPL, 1978 DEC 6
691 *
692 * .. Scalar Arguments ..
693  DOUBLE PRECISION SFAC
694  INTEGER LEN
695 * .. Array Arguments ..
696  COMPLEX*16 CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
697 * .. Local Scalars ..
698  INTEGER I
699 * .. Local Arrays ..
700  DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20)
701 * .. External Subroutines ..
702  EXTERNAL stest
703 * .. Intrinsic Functions ..
704  INTRINSIC dimag, dble
705 * .. Executable Statements ..
706  DO 20 i = 1, len
707  scomp(2*i-1) = dble(ccomp(i))
708  scomp(2*i) = dimag(ccomp(i))
709  strue(2*i-1) = dble(ctrue(i))
710  strue(2*i) = dimag(ctrue(i))
711  ssize(2*i-1) = dble(csize(i))
712  ssize(2*i) = dimag(csize(i))
713  20 CONTINUE
714 *
715  CALL stest(2*len,scomp,strue,ssize,sfac)
716  RETURN
717  END
718  SUBROUTINE itest1(ICOMP,ITRUE)
719 * ********************************* ITEST1 *************************
720 *
721 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
722 * EQUALITY.
723 * C. L. LAWSON, JPL, 1974 DEC 10
724 *
725 * .. Parameters ..
726  INTEGER NOUT
727  parameter(nout=6)
728 * .. Scalar Arguments ..
729  INTEGER ICOMP, ITRUE
730 * .. Scalars in Common ..
731  INTEGER ICASE, INCX, INCY, MODE, N
732  LOGICAL PASS
733 * .. Local Scalars ..
734  INTEGER ID
735 * .. Common blocks ..
736  COMMON /combla/icase, n, incx, incy, mode, pass
737 * .. Executable Statements ..
738  IF (icomp.EQ.itrue) GO TO 40
739 *
740 * HERE ICOMP IS NOT EQUAL TO ITRUE.
741 *
742  IF ( .NOT. pass) GO TO 20
743 * PRINT FAIL MESSAGE AND HEADER.
744  pass = .false.
745  WRITE (nout,99999)
746  WRITE (nout,99998)
747  20 id = icomp - itrue
748  WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
749  40 CONTINUE
750  RETURN
751 *
752 99999 FORMAT (' FAIL')
753 99998 FORMAT (/' CASE N INCX INCY MODE ',
754  + ' COMP TRUE DIFFERENCE',
755  + /1x)
756 99997 FORMAT (1x,i4,i3,3i5,2i36,i12)
757  END
stest
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:597
header
subroutine header
Definition: cblat1.f:88
sdiff
real function sdiff(SA, SB)
Definition: cblat1.f:678
check1
subroutine check1(SFAC)
Definition: cblat1.f:116
check2
subroutine check2(SFAC)
Definition: cblat1.f:334
stest1
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:653
ctest
subroutine ctest(LEN, CCOMP, CTRUE, CSIZE, SFAC)
Definition: cblat1.f:688
itest1
subroutine itest1(ICOMP, ITRUE)
Definition: cblat1.f:719
zswap
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
Definition: zswap.f:81
zdscal
subroutine zdscal(N, DA, ZX, INCX)
ZDSCAL
Definition: zdscal.f:78
zaxpy
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY
Definition: zaxpy.f:88
zscal
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
Definition: zscal.f:78
zcopy
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:81
zblat1
program zblat1
ZBLAT1
Definition: zblat1.f:36