Gitiles
Code Review Sign In
realtimeroboticsgroup.org / RealtimeRoboticsGroup / test / c1ded373f365b8ed2238f70d6885fabf39e9cd88 / . / third_party / eigen / blas / testing / zblat1.f
blob: c00b67dc82b23e9273e59a9f30b2fd8cb43d2f13 [file] [log] [blame]
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]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* =====================================================================
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]38 PROGRAM ZBLAT1
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]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*
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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*
8799999 FORMAT (' Complex BLAS Test Program Results',/1X)
8899998 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*
11699999 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),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]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),
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]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/
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]190 + (0.19D0,-0.17D0), (0.20D0,-0.35D0),
191 + (0.35D0,0.20D0), (0.14D0,0.08D0),
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]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)/
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]222 + (0.09D0,0.03D0), (0.15D0,0.00D0),
223 + (0.00D0,0.15D0), (0.00D0,0.06D0), (2.0D0,3.0D0),
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]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)/
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]574 DOUBLE PRECISION ZERO
575 PARAMETER (NOUT=6, ZERO=0.0D0)
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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)
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]598 IF (ABS(SFAC*SD) .LE. ABS(SSIZE(I))*EPSILON(ZERO))
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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*
61399999 FORMAT (' FAIL')
61499998 FORMAT (/' CASE N INCX INCY MODE I ',
615 + ' COMP(I) TRUE(I) DIFFERENCE',
616 + ' SIZE(I)',/1X)
61799997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4)
618 END
619 SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
620* ************************* STEST1 *****************************
621*
Austin Schuhc55b0172022-02-20 17:52:35 -0800[diff] [blame]622* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]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*
71999999 FORMAT (' FAIL')
72099998 FORMAT (/' CASE N INCX INCY MODE ',
721 + ' COMP TRUE DIFFERENCE',
722 + /1X)
72399997 FORMAT (1X,I4,I3,3I5,2I36,I12)
724 END