LAPACK  3.10.0
LAPACK: Linear Algebra PACKage
cblat1.f
Go to the documentation of this file.
1 *> \brief \b CBLAT1
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 CBLAT1
12 *
13 *
14 *> \par Purpose:
15 * =============
16 *>
17 *> \verbatim
18 *>
19 *> Test program for the COMPLEX Level 1 BLAS.
20 *> Based upon the original BLAS test routine together with:
21 *>
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 complex_blas_testing
34 *
35 * =====================================================================
36  PROGRAM cblat1
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  REAL 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.765625e-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 *
87 * End of CBLAT1
88 *
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)/'CDOTC '/
103  DATA l(2)/'CDOTU '/
104  DATA l(3)/'CAXPY '/
105  DATA l(4)/'CCOPY '/
106  DATA l(5)/'CSWAP '/
107  DATA l(6)/'SCNRM2'/
108  DATA l(7)/'SCASUM'/
109  DATA l(8)/'CSCAL '/
110  DATA l(9)/'CSSCAL'/
111  DATA l(10)/'ICAMAX'/
112 * .. Executable Statements ..
113  WRITE (nout,99999) icase, l(icase)
114  RETURN
115 *
116 99999 FORMAT (/' Test of subprogram number',i3,12x,a6)
117 *
118 * End of HEADER
119 *
120  END
121  SUBROUTINE check1(SFAC)
122 * .. Parameters ..
123  INTEGER NOUT
124  parameter(nout=6)
125 * .. Scalar Arguments ..
126  REAL SFAC
127 * .. Scalars in Common ..
128  INTEGER ICASE, INCX, INCY, MODE, N
129  LOGICAL PASS
130 * .. Local Scalars ..
131  COMPLEX CA
132  REAL SA
133  INTEGER I, IX, J, LEN, NP1
134 * .. Local Arrays ..
135  COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CVR(8),
136  + CX(8), CXR(15), MWPCS(5), MWPCT(5)
137  REAL STRUE2(5), STRUE4(5)
138  INTEGER ITRUE3(5), ITRUEC(5)
139 * .. External Functions ..
140  REAL SCASUM, SCNRM2
141  INTEGER ICAMAX
142  EXTERNAL scasum, scnrm2, icamax
143 * .. External Subroutines ..
144  EXTERNAL cscal, csscal, ctest, itest1, stest1
145 * .. Intrinsic Functions ..
146  INTRINSIC max
147 * .. Common blocks ..
148  COMMON /combla/icase, n, incx, incy, mode, pass
149 * .. Data statements ..
150  DATA sa, ca/0.3e0, (0.4e0,-0.7e0)/
151  DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
152  + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
153  + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
154  + (1.0e0,2.0e0), (0.3e0,-0.4e0), (3.0e0,4.0e0),
155  + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
156  + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
157  + (0.1e0,-0.3e0), (0.5e0,-0.1e0), (5.0e0,6.0e0),
158  + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
159  + (5.0e0,6.0e0), (5.0e0,6.0e0), (0.1e0,0.1e0),
160  + (-0.6e0,0.1e0), (0.1e0,-0.3e0), (7.0e0,8.0e0),
161  + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
162  + (7.0e0,8.0e0), (0.3e0,0.1e0), (0.5e0,0.0e0),
163  + (0.0e0,0.5e0), (0.0e0,0.2e0), (2.0e0,3.0e0),
164  + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
165  DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
166  + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
167  + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
168  + (4.0e0,5.0e0), (0.3e0,-0.4e0), (6.0e0,7.0e0),
169  + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
170  + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
171  + (0.1e0,-0.3e0), (8.0e0,9.0e0), (0.5e0,-0.1e0),
172  + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
173  + (2.0e0,5.0e0), (2.0e0,5.0e0), (0.1e0,0.1e0),
174  + (3.0e0,6.0e0), (-0.6e0,0.1e0), (4.0e0,7.0e0),
175  + (0.1e0,-0.3e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
176  + (7.0e0,2.0e0), (0.3e0,0.1e0), (5.0e0,8.0e0),
177  + (0.5e0,0.0e0), (6.0e0,9.0e0), (0.0e0,0.5e0),
178  + (8.0e0,3.0e0), (0.0e0,0.2e0), (9.0e0,4.0e0)/
179  DATA cvr/(8.0e0,8.0e0), (-7.0e0,-7.0e0),
180  + (9.0e0,9.0e0), (5.0e0,5.0e0), (9.0e0,9.0e0),
181  + (8.0e0,8.0e0), (7.0e0,7.0e0), (7.0e0,7.0e0)/
182  DATA strue2/0.0e0, 0.5e0, 0.6e0, 0.7e0, 0.8e0/
183  DATA strue4/0.0e0, 0.7e0, 1.0e0, 1.3e0, 1.6e0/
184  DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
185  + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
186  + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
187  + (1.0e0,2.0e0), (-0.16e0,-0.37e0), (3.0e0,4.0e0),
188  + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
189  + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
190  + (-0.17e0,-0.19e0), (0.13e0,-0.39e0),
191  + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
192  + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
193  + (0.11e0,-0.03e0), (-0.17e0,0.46e0),
194  + (-0.17e0,-0.19e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
195  + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
196  + (0.19e0,-0.17e0), (0.20e0,-0.35e0),
197  + (0.35e0,0.20e0), (0.14e0,0.08e0),
198  + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0),
199  + (2.0e0,3.0e0)/
200  DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
201  + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
202  + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
203  + (4.0e0,5.0e0), (-0.16e0,-0.37e0), (6.0e0,7.0e0),
204  + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
205  + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
206  + (-0.17e0,-0.19e0), (8.0e0,9.0e0),
207  + (0.13e0,-0.39e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
208  + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
209  + (0.11e0,-0.03e0), (3.0e0,6.0e0),
210  + (-0.17e0,0.46e0), (4.0e0,7.0e0),
211  + (-0.17e0,-0.19e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
212  + (7.0e0,2.0e0), (0.19e0,-0.17e0), (5.0e0,8.0e0),
213  + (0.20e0,-0.35e0), (6.0e0,9.0e0),
214  + (0.35e0,0.20e0), (8.0e0,3.0e0),
215  + (0.14e0,0.08e0), (9.0e0,4.0e0)/
216  DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
217  + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
218  + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
219  + (1.0e0,2.0e0), (0.09e0,-0.12e0), (3.0e0,4.0e0),
220  + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
221  + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
222  + (0.03e0,-0.09e0), (0.15e0,-0.03e0),
223  + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
224  + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
225  + (0.03e0,0.03e0), (-0.18e0,0.03e0),
226  + (0.03e0,-0.09e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
227  + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
228  + (0.09e0,0.03e0), (0.15e0,0.00e0),
229  + (0.00e0,0.15e0), (0.00e0,0.06e0), (2.0e0,3.0e0),
230  + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
231  DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
232  + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
233  + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
234  + (4.0e0,5.0e0), (0.09e0,-0.12e0), (6.0e0,7.0e0),
235  + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
236  + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
237  + (0.03e0,-0.09e0), (8.0e0,9.0e0),
238  + (0.15e0,-0.03e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
239  + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
240  + (0.03e0,0.03e0), (3.0e0,6.0e0),
241  + (-0.18e0,0.03e0), (4.0e0,7.0e0),
242  + (0.03e0,-0.09e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
243  + (7.0e0,2.0e0), (0.09e0,0.03e0), (5.0e0,8.0e0),
244  + (0.15e0,0.00e0), (6.0e0,9.0e0), (0.00e0,0.15e0),
245  + (8.0e0,3.0e0), (0.00e0,0.06e0), (9.0e0,4.0e0)/
246  DATA itrue3/0, 1, 2, 2, 2/
247  DATA itruec/0, 1, 1, 1, 1/
248 * .. Executable Statements ..
249  DO 60 incx = 1, 2
250  DO 40 np1 = 1, 5
251  n = np1 - 1
252  len = 2*max(n,1)
253 * .. Set vector arguments ..
254  DO 20 i = 1, len
255  cx(i) = cv(i,np1,incx)
256  20 CONTINUE
257  IF (icase.EQ.6) THEN
258 * .. SCNRM2 ..
259  CALL stest1(scnrm2(n,cx,incx),strue2(np1),strue2(np1),
260  + sfac)
261  ELSE IF (icase.EQ.7) THEN
262 * .. SCASUM ..
263  CALL stest1(scasum(n,cx,incx),strue4(np1),strue4(np1),
264  + sfac)
265  ELSE IF (icase.EQ.8) THEN
266 * .. CSCAL ..
267  CALL cscal(n,ca,cx,incx)
268  CALL ctest(len,cx,ctrue5(1,np1,incx),ctrue5(1,np1,incx),
269  + sfac)
270  ELSE IF (icase.EQ.9) THEN
271 * .. CSSCAL ..
272  CALL csscal(n,sa,cx,incx)
273  CALL ctest(len,cx,ctrue6(1,np1,incx),ctrue6(1,np1,incx),
274  + sfac)
275  ELSE IF (icase.EQ.10) THEN
276 * .. ICAMAX ..
277  CALL itest1(icamax(n,cx,incx),itrue3(np1))
278  DO 160 i = 1, len
279  cx(i) = (42.0e0,43.0e0)
280  160 CONTINUE
281  CALL itest1(icamax(n,cx,incx),itruec(np1))
282  ELSE
283  WRITE (nout,*) ' Shouldn''t be here in CHECK1'
284  stop
285  END IF
286 *
287  40 CONTINUE
288  IF (icase.EQ.10) THEN
289  n = 8
290  ix = 1
291  DO 180 i = 1, n
292  cxr(ix) = cvr(i)
293  ix = ix + incx
294  180 CONTINUE
295  CALL itest1(icamax(n,cxr,incx),3)
296  END IF
297  60 CONTINUE
298 *
299  incx = 1
300  IF (icase.EQ.8) THEN
301 * CSCAL
302 * Add a test for alpha equal to zero.
303  ca = (0.0e0,0.0e0)
304  DO 80 i = 1, 5
305  mwpct(i) = (0.0e0,0.0e0)
306  mwpcs(i) = (1.0e0,1.0e0)
307  80 CONTINUE
308  CALL cscal(5,ca,cx,incx)
309  CALL ctest(5,cx,mwpct,mwpcs,sfac)
310  ELSE IF (icase.EQ.9) THEN
311 * CSSCAL
312 * Add a test for alpha equal to zero.
313  sa = 0.0e0
314  DO 100 i = 1, 5
315  mwpct(i) = (0.0e0,0.0e0)
316  mwpcs(i) = (1.0e0,1.0e0)
317  100 CONTINUE
318  CALL csscal(5,sa,cx,incx)
319  CALL ctest(5,cx,mwpct,mwpcs,sfac)
320 * Add a test for alpha equal to one.
321  sa = 1.0e0
322  DO 120 i = 1, 5
323  mwpct(i) = cx(i)
324  mwpcs(i) = cx(i)
325  120 CONTINUE
326  CALL csscal(5,sa,cx,incx)
327  CALL ctest(5,cx,mwpct,mwpcs,sfac)
328 * Add a test for alpha equal to minus one.
329  sa = -1.0e0
330  DO 140 i = 1, 5
331  mwpct(i) = -cx(i)
332  mwpcs(i) = -cx(i)
333  140 CONTINUE
334  CALL csscal(5,sa,cx,incx)
335  CALL ctest(5,cx,mwpct,mwpcs,sfac)
336  END IF
337  RETURN
338 *
339 * End of CHECK1
340 *
341  END
342  SUBROUTINE check2(SFAC)
343 * .. Parameters ..
344  INTEGER NOUT
345  parameter(nout=6)
346 * .. Scalar Arguments ..
347  REAL SFAC
348 * .. Scalars in Common ..
349  INTEGER ICASE, INCX, INCY, MODE, N
350  LOGICAL PASS
351 * .. Local Scalars ..
352  COMPLEX CA
353  INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
354  + MX, MY
355 * .. Local Arrays ..
356  COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
357  + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
358  + CT8(7,4,4), CTY0(1), CX(7), CX0(1), CX1(7),
359  + CY(7), CY0(1), CY1(7)
360  INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
361 * .. External Functions ..
362  COMPLEX CDOTC, CDOTU
363  EXTERNAL cdotc, cdotu
364 * .. External Subroutines ..
365  EXTERNAL caxpy, ccopy, cswap, ctest
366 * .. Intrinsic Functions ..
367  INTRINSIC abs, min
368 * .. Common blocks ..
369  COMMON /combla/icase, n, incx, incy, mode, pass
370 * .. Data statements ..
371  DATA ca/(0.4e0,-0.7e0)/
372  DATA incxs/1, 2, -2, -1/
373  DATA incys/1, -2, 1, -2/
374  DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
375  DATA ns/0, 1, 2, 4/
376  DATA cx1/(0.7e0,-0.8e0), (-0.4e0,-0.7e0),
377  + (-0.1e0,-0.9e0), (0.2e0,-0.8e0),
378  + (-0.9e0,-0.4e0), (0.1e0,0.4e0), (-0.6e0,0.6e0)/
379  DATA cy1/(0.6e0,-0.6e0), (-0.9e0,0.5e0),
380  + (0.7e0,-0.6e0), (0.1e0,-0.5e0), (-0.1e0,-0.2e0),
381  + (-0.5e0,-0.3e0), (0.8e0,-0.7e0)/
382  DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
383  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
384  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
385  + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
386  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
387  + (0.0e0,0.0e0), (0.32e0,-1.41e0),
388  + (-1.55e0,0.5e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
389  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
390  + (0.32e0,-1.41e0), (-1.55e0,0.5e0),
391  + (0.03e0,-0.89e0), (-0.38e0,-0.96e0),
392  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
393  DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
394  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
395  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
396  + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
397  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
398  + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
399  + (-0.9e0,0.5e0), (0.42e0,-1.41e0), (0.0e0,0.0e0),
400  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
401  + (0.78e0,0.06e0), (-0.9e0,0.5e0),
402  + (0.06e0,-0.13e0), (0.1e0,-0.5e0),
403  + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
404  + (0.52e0,-1.51e0)/
405  DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
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.32e0,-1.41e0), (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.07e0,-0.89e0),
411  + (-1.18e0,-0.31e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
412  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
413  + (0.78e0,0.06e0), (-1.54e0,0.97e0),
414  + (0.03e0,-0.89e0), (-0.18e0,-1.31e0),
415  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
416  DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
417  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
418  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
419  + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
420  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
421  + (0.0e0,0.0e0), (0.32e0,-1.41e0), (-0.9e0,0.5e0),
422  + (0.05e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
423  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.32e0,-1.41e0),
424  + (-0.9e0,0.5e0), (0.05e0,-0.6e0), (0.1e0,-0.5e0),
425  + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
426  + (0.32e0,-1.16e0)/
427  DATA ct7/(0.0e0,0.0e0), (-0.06e0,-0.90e0),
428  + (0.65e0,-0.47e0), (-0.34e0,-1.22e0),
429  + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
430  + (-0.59e0,-1.46e0), (-1.04e0,-0.04e0),
431  + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
432  + (-0.83e0,0.59e0), (0.07e0,-0.37e0),
433  + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
434  + (-0.76e0,-1.15e0), (-1.33e0,-1.82e0)/
435  DATA ct6/(0.0e0,0.0e0), (0.90e0,0.06e0),
436  + (0.91e0,-0.77e0), (1.80e0,-0.10e0),
437  + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.45e0,0.74e0),
438  + (0.20e0,0.90e0), (0.0e0,0.0e0), (0.90e0,0.06e0),
439  + (-0.55e0,0.23e0), (0.83e0,-0.39e0),
440  + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.04e0,0.79e0),
441  + (1.95e0,1.22e0)/
442  DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(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.0e0,0.0e0),
445  + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
446  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
447  + (0.0e0,0.0e0), (0.6e0,-0.6e0), (-0.9e0,0.5e0),
448  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
449  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
450  + (-0.9e0,0.5e0), (0.7e0,-0.6e0), (0.1e0,-0.5e0),
451  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
452  DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7e0,-0.8e0),
453  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
454  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
455  + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
456  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
457  + (0.0e0,0.0e0), (0.7e0,-0.6e0), (-0.4e0,-0.7e0),
458  + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
459  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.8e0,-0.7e0),
460  + (-0.4e0,-0.7e0), (-0.1e0,-0.2e0),
461  + (0.2e0,-0.8e0), (0.7e0,-0.6e0), (0.1e0,0.4e0),
462  + (0.6e0,-0.6e0)/
463  DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7e0,-0.8e0),
464  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
465  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
466  + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
467  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
468  + (0.0e0,0.0e0), (-0.9e0,0.5e0), (-0.4e0,-0.7e0),
469  + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
470  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.1e0,-0.5e0),
471  + (-0.4e0,-0.7e0), (0.7e0,-0.6e0), (0.2e0,-0.8e0),
472  + (-0.9e0,0.5e0), (0.1e0,0.4e0), (0.6e0,-0.6e0)/
473  DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7e0,-0.8e0),
474  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
475  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
476  + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
477  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
478  + (0.0e0,0.0e0), (0.6e0,-0.6e0), (0.7e0,-0.6e0),
479  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
480  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
481  + (0.7e0,-0.6e0), (-0.1e0,-0.2e0), (0.8e0,-0.7e0),
482  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
483  DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
484  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
485  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
486  + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
487  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
488  + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.4e0,-0.7e0),
489  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
490  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
491  + (-0.4e0,-0.7e0), (-0.1e0,-0.9e0),
492  + (0.2e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
493  + (0.0e0,0.0e0)/
494  DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
495  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
496  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
497  + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
498  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
499  + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (-0.9e0,0.5e0),
500  + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
501  + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
502  + (-0.9e0,0.5e0), (-0.9e0,-0.4e0), (0.1e0,-0.5e0),
503  + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
504  + (0.7e0,-0.8e0)/
505  DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
506  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
507  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
508  + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
509  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
510  + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (0.7e0,-0.8e0),
511  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
512  + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
513  + (-0.9e0,-0.4e0), (-0.1e0,-0.9e0),
514  + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
515  + (0.0e0,0.0e0)/
516  DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
517  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
518  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
519  + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
520  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
521  + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.9e0,0.5e0),
522  + (-0.4e0,-0.7e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
523  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
524  + (-0.9e0,0.5e0), (-0.4e0,-0.7e0), (0.1e0,-0.5e0),
525  + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
526  + (0.2e0,-0.8e0)/
527  DATA csize1/(0.0e0,0.0e0), (0.9e0,0.9e0),
528  + (1.63e0,1.73e0), (2.90e0,2.78e0)/
529  DATA csize3/(0.0e0,0.0e0), (0.0e0,0.0e0),
530  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
531  + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.17e0,1.17e0),
532  + (1.17e0,1.17e0), (1.17e0,1.17e0),
533  + (1.17e0,1.17e0), (1.17e0,1.17e0),
534  + (1.17e0,1.17e0), (1.17e0,1.17e0)/
535  DATA csize2/(0.0e0,0.0e0), (0.0e0,0.0e0),
536  + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
537  + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.54e0,1.54e0),
538  + (1.54e0,1.54e0), (1.54e0,1.54e0),
539  + (1.54e0,1.54e0), (1.54e0,1.54e0),
540  + (1.54e0,1.54e0), (1.54e0,1.54e0)/
541 * .. Executable Statements ..
542  DO 60 ki = 1, 4
543  incx = incxs(ki)
544  incy = incys(ki)
545  mx = abs(incx)
546  my = abs(incy)
547 *
548  DO 40 kn = 1, 4
549  n = ns(kn)
550  ksize = min(2,kn)
551  lenx = lens(kn,mx)
552  leny = lens(kn,my)
553 * .. initialize all argument arrays ..
554  DO 20 i = 1, 7
555  cx(i) = cx1(i)
556  cy(i) = cy1(i)
557  20 CONTINUE
558  IF (icase.EQ.1) THEN
559 * .. CDOTC ..
560  cdot(1) = cdotc(n,cx,incx,cy,incy)
561  CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
562  ELSE IF (icase.EQ.2) THEN
563 * .. CDOTU ..
564  cdot(1) = cdotu(n,cx,incx,cy,incy)
565  CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
566  ELSE IF (icase.EQ.3) THEN
567 * .. CAXPY ..
568  CALL caxpy(n,ca,cx,incx,cy,incy)
569  CALL ctest(leny,cy,ct8(1,kn,ki),csize2(1,ksize),sfac)
570  ELSE IF (icase.EQ.4) THEN
571 * .. CCOPY ..
572  CALL ccopy(n,cx,incx,cy,incy)
573  CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
574  IF (ki.EQ.1) THEN
575  cx0(1) = (42.0e0,43.0e0)
576  cy0(1) = (44.0e0,45.0e0)
577  IF (n.EQ.0) THEN
578  cty0(1) = cy0(1)
579  ELSE
580  cty0(1) = cx0(1)
581  END IF
582  lincx = incx
583  incx = 0
584  lincy = incy
585  incy = 0
586  CALL ccopy(n,cx0,incx,cy0,incy)
587  CALL ctest(1,cy0,cty0,csize3,1.0e0)
588  incx = lincx
589  incy = lincy
590  END IF
591  ELSE IF (icase.EQ.5) THEN
592 * .. CSWAP ..
593  CALL cswap(n,cx,incx,cy,incy)
594  CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0e0)
595  CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
596  ELSE
597  WRITE (nout,*) ' Shouldn''t be here in CHECK2'
598  stop
599  END IF
600 *
601  40 CONTINUE
602  60 CONTINUE
603  RETURN
604 *
605 * End of CHECK2
606 *
607  END
608  SUBROUTINE stest(LEN,SCOMP,STRUE,SSIZE,SFAC)
609 * ********************************* STEST **************************
610 *
611 * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
612 * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
613 * NEGLIGIBLE.
614 *
615 * C. L. LAWSON, JPL, 1974 DEC 10
616 *
617 * .. Parameters ..
618  INTEGER NOUT
619  REAL ZERO
620  parameter(nout=6, zero=0.0e0)
621 * .. Scalar Arguments ..
622  REAL SFAC
623  INTEGER LEN
624 * .. Array Arguments ..
625  REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
626 * .. Scalars in Common ..
627  INTEGER ICASE, INCX, INCY, MODE, N
628  LOGICAL PASS
629 * .. Local Scalars ..
630  REAL SD
631  INTEGER I
632 * .. External Functions ..
633  REAL SDIFF
634  EXTERNAL sdiff
635 * .. Intrinsic Functions ..
636  INTRINSIC abs
637 * .. Common blocks ..
638  COMMON /combla/icase, n, incx, incy, mode, pass
639 * .. Executable Statements ..
640 *
641  DO 40 i = 1, len
642  sd = scomp(i) - strue(i)
643  IF (abs(sfac*sd) .LE. abs(ssize(i))*epsilon(zero))
644  + GO TO 40
645 *
646 * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
647 *
648  IF ( .NOT. pass) GO TO 20
649 * PRINT FAIL MESSAGE AND HEADER.
650  pass = .false.
651  WRITE (nout,99999)
652  WRITE (nout,99998)
653  20 WRITE (nout,99997) icase, n, incx, incy, mode, i, scomp(i),
654  + strue(i), sd, ssize(i)
655  40 CONTINUE
656  RETURN
657 *
658 99999 FORMAT (' FAIL')
659 99998 FORMAT (/' CASE N INCX INCY MODE I ',
660  + ' COMP(I) TRUE(I) DIFFERENCE',
661  + ' SIZE(I)',/1x)
662 99997 FORMAT (1x,i4,i3,3i5,i3,2e36.8,2e12.4)
663 *
664 * End of STEST
665 *
666  END
667  SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
668 * ************************* STEST1 *****************************
669 *
670 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
671 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
672 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
673 *
674 * C.L. LAWSON, JPL, 1978 DEC 6
675 *
676 * .. Scalar Arguments ..
677  REAL SCOMP1, SFAC, STRUE1
678 * .. Array Arguments ..
679  REAL SSIZE(*)
680 * .. Local Arrays ..
681  REAL SCOMP(1), STRUE(1)
682 * .. External Subroutines ..
683  EXTERNAL stest
684 * .. Executable Statements ..
685 *
686  scomp(1) = scomp1
687  strue(1) = strue1
688  CALL stest(1,scomp,strue,ssize,sfac)
689 *
690  RETURN
691 *
692 * End of STEST1
693 *
694  END
695  REAL function sdiff(sa,sb)
696 * ********************************* SDIFF **************************
697 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
698 *
699 * .. Scalar Arguments ..
700  REAL sa, sb
701 * .. Executable Statements ..
702  sdiff = sa - sb
703  RETURN
704 *
705 * End of SDIFF
706 *
707  END
708  SUBROUTINE ctest(LEN,CCOMP,CTRUE,CSIZE,SFAC)
709 * **************************** CTEST *****************************
710 *
711 * C.L. LAWSON, JPL, 1978 DEC 6
712 *
713 * .. Scalar Arguments ..
714  REAL SFAC
715  INTEGER LEN
716 * .. Array Arguments ..
717  COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
718 * .. Local Scalars ..
719  INTEGER I
720 * .. Local Arrays ..
721  REAL SCOMP(20), SSIZE(20), STRUE(20)
722 * .. External Subroutines ..
723  EXTERNAL stest
724 * .. Intrinsic Functions ..
725  INTRINSIC aimag, real
726 * .. Executable Statements ..
727  DO 20 i = 1, len
728  scomp(2*i-1) = real(ccomp(i))
729  scomp(2*i) = aimag(ccomp(i))
730  strue(2*i-1) = real(ctrue(i))
731  strue(2*i) = aimag(ctrue(i))
732  ssize(2*i-1) = real(csize(i))
733  ssize(2*i) = aimag(csize(i))
734  20 CONTINUE
735 *
736  CALL stest(2*len,scomp,strue,ssize,sfac)
737  RETURN
738 *
739 * End of CTEST
740 *
741  END
742  SUBROUTINE itest1(ICOMP,ITRUE)
743 * ********************************* ITEST1 *************************
744 *
745 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
746 * EQUALITY.
747 * C. L. LAWSON, JPL, 1974 DEC 10
748 *
749 * .. Parameters ..
750  INTEGER NOUT
751  parameter(nout=6)
752 * .. Scalar Arguments ..
753  INTEGER ICOMP, ITRUE
754 * .. Scalars in Common ..
755  INTEGER ICASE, INCX, INCY, MODE, N
756  LOGICAL PASS
757 * .. Local Scalars ..
758  INTEGER ID
759 * .. Common blocks ..
760  COMMON /combla/icase, n, incx, incy, mode, pass
761 * .. Executable Statements ..
762  IF (icomp.EQ.itrue) GO TO 40
763 *
764 * HERE ICOMP IS NOT EQUAL TO ITRUE.
765 *
766  IF ( .NOT. pass) GO TO 20
767 * PRINT FAIL MESSAGE AND HEADER.
768  pass = .false.
769  WRITE (nout,99999)
770  WRITE (nout,99998)
771  20 id = icomp - itrue
772  WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
773  40 CONTINUE
774  RETURN
775 *
776 99999 FORMAT (' FAIL')
777 99998 FORMAT (/' CASE N INCX INCY MODE ',
778  + ' COMP TRUE DIFFERENCE',
779  + /1x)
780 99997 FORMAT (1x,i4,i3,3i5,2i36,i12)
781 *
782 * End of ITEST1
783 *
784  END
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:609
subroutine header
Definition: cblat1.f:91
real function sdiff(SA, SB)
Definition: cblat1.f:696
subroutine check1(SFAC)
Definition: cblat1.f:122
subroutine check2(SFAC)
Definition: cblat1.f:343
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:668
subroutine ctest(LEN, CCOMP, CTRUE, CSIZE, SFAC)
Definition: cblat1.f:709
subroutine itest1(ICOMP, ITRUE)
Definition: cblat1.f:743
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:81
subroutine csscal(N, SA, CX, INCX)
CSSCAL
Definition: csscal.f:78
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
Definition: caxpy.f:88
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
Definition: cswap.f:81
subroutine cscal(N, CA, CX, INCX)
CSCAL
Definition: cscal.f:78
program cblat1
CBLAT1
Definition: cblat1.f:36