Gitiles
Code Review Sign In
realtimeroboticsgroup.org / RealtimeRoboticsGroup / test / a57b70145cb0a950c1c3a9a4fddf0438c60126f2 / . / third_party / eigen / blas / testing / cblat1.f
blob: 8ca67fb19934250cce1a19616fbcd17a22d26707 [file] [log] [blame]
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]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*> \date April 2012
34*
35*> \ingroup complex_blas_testing
36*
37* =====================================================================
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]38 PROGRAM CBLAT1
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 REAL 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.765625E-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)/'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*
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 REAL SFAC
124* .. Scalars in Common ..
125 INTEGER ICASE, INCX, INCY, MODE, N
126 LOGICAL PASS
127* .. Local Scalars ..
128 COMPLEX CA
129 REAL SA
130 INTEGER I, J, LEN, NP1
131* .. Local Arrays ..
132 COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CX(8),
133 + MWPCS(5), MWPCT(5)
134 REAL STRUE2(5), STRUE4(5)
135 INTEGER ITRUE3(5)
136* .. External Functions ..
137 REAL SCASUM, SCNRM2
138 INTEGER ICAMAX
139 EXTERNAL SCASUM, SCNRM2, ICAMAX
140* .. External Subroutines ..
141 EXTERNAL CSCAL, CSSCAL, 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.3E0, (0.4E0,-0.7E0)/
148 DATA ((CV(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0),
149 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
150 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
151 + (1.0E0,2.0E0), (0.3E0,-0.4E0), (3.0E0,4.0E0),
152 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
153 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
154 + (0.1E0,-0.3E0), (0.5E0,-0.1E0), (5.0E0,6.0E0),
155 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
156 + (5.0E0,6.0E0), (5.0E0,6.0E0), (0.1E0,0.1E0),
157 + (-0.6E0,0.1E0), (0.1E0,-0.3E0), (7.0E0,8.0E0),
158 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]159 + (7.0E0,8.0E0), (0.3E0,0.1E0), (0.5E0,0.0E0),
160 + (0.0E0,0.5E0), (0.0E0,0.2E0), (2.0E0,3.0E0),
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]161 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/
162 DATA ((CV(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0),
163 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
164 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
165 + (4.0E0,5.0E0), (0.3E0,-0.4E0), (6.0E0,7.0E0),
166 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
167 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
168 + (0.1E0,-0.3E0), (8.0E0,9.0E0), (0.5E0,-0.1E0),
169 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
170 + (2.0E0,5.0E0), (2.0E0,5.0E0), (0.1E0,0.1E0),
171 + (3.0E0,6.0E0), (-0.6E0,0.1E0), (4.0E0,7.0E0),
172 + (0.1E0,-0.3E0), (7.0E0,2.0E0), (7.0E0,2.0E0),
173 + (7.0E0,2.0E0), (0.3E0,0.1E0), (5.0E0,8.0E0),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]174 + (0.5E0,0.0E0), (6.0E0,9.0E0), (0.0E0,0.5E0),
175 + (8.0E0,3.0E0), (0.0E0,0.2E0), (9.0E0,4.0E0)/
176 DATA STRUE2/0.0E0, 0.5E0, 0.6E0, 0.7E0, 0.8E0/
177 DATA STRUE4/0.0E0, 0.7E0, 1.0E0, 1.3E0, 1.6E0/
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]178 DATA ((CTRUE5(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0),
179 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
180 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
181 + (1.0E0,2.0E0), (-0.16E0,-0.37E0), (3.0E0,4.0E0),
182 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
183 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
184 + (-0.17E0,-0.19E0), (0.13E0,-0.39E0),
185 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
186 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
187 + (0.11E0,-0.03E0), (-0.17E0,0.46E0),
188 + (-0.17E0,-0.19E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
189 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]190 + (0.19E0,-0.17E0), (0.20E0,-0.35E0),
191 + (0.35E0,0.20E0), (0.14E0,0.08E0),
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]192 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0),
193 + (2.0E0,3.0E0)/
194 DATA ((CTRUE5(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0),
195 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
196 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
197 + (4.0E0,5.0E0), (-0.16E0,-0.37E0), (6.0E0,7.0E0),
198 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
199 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
200 + (-0.17E0,-0.19E0), (8.0E0,9.0E0),
201 + (0.13E0,-0.39E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
202 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
203 + (0.11E0,-0.03E0), (3.0E0,6.0E0),
204 + (-0.17E0,0.46E0), (4.0E0,7.0E0),
205 + (-0.17E0,-0.19E0), (7.0E0,2.0E0), (7.0E0,2.0E0),
206 + (7.0E0,2.0E0), (0.19E0,-0.17E0), (5.0E0,8.0E0),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]207 + (0.20E0,-0.35E0), (6.0E0,9.0E0),
208 + (0.35E0,0.20E0), (8.0E0,3.0E0),
209 + (0.14E0,0.08E0), (9.0E0,4.0E0)/
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]210 DATA ((CTRUE6(I,J,1),I=1,8),J=1,5)/(0.1E0,0.1E0),
211 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
212 + (1.0E0,2.0E0), (1.0E0,2.0E0), (1.0E0,2.0E0),
213 + (1.0E0,2.0E0), (0.09E0,-0.12E0), (3.0E0,4.0E0),
214 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
215 + (3.0E0,4.0E0), (3.0E0,4.0E0), (3.0E0,4.0E0),
216 + (0.03E0,-0.09E0), (0.15E0,-0.03E0),
217 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
218 + (5.0E0,6.0E0), (5.0E0,6.0E0), (5.0E0,6.0E0),
219 + (0.03E0,0.03E0), (-0.18E0,0.03E0),
220 + (0.03E0,-0.09E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
221 + (7.0E0,8.0E0), (7.0E0,8.0E0), (7.0E0,8.0E0),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]222 + (0.09E0,0.03E0), (0.15E0,0.00E0),
223 + (0.00E0,0.15E0), (0.00E0,0.06E0), (2.0E0,3.0E0),
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]224 + (2.0E0,3.0E0), (2.0E0,3.0E0), (2.0E0,3.0E0)/
225 DATA ((CTRUE6(I,J,2),I=1,8),J=1,5)/(0.1E0,0.1E0),
226 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
227 + (4.0E0,5.0E0), (4.0E0,5.0E0), (4.0E0,5.0E0),
228 + (4.0E0,5.0E0), (0.09E0,-0.12E0), (6.0E0,7.0E0),
229 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
230 + (6.0E0,7.0E0), (6.0E0,7.0E0), (6.0E0,7.0E0),
231 + (0.03E0,-0.09E0), (8.0E0,9.0E0),
232 + (0.15E0,-0.03E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
233 + (2.0E0,5.0E0), (2.0E0,5.0E0), (2.0E0,5.0E0),
234 + (0.03E0,0.03E0), (3.0E0,6.0E0),
235 + (-0.18E0,0.03E0), (4.0E0,7.0E0),
236 + (0.03E0,-0.09E0), (7.0E0,2.0E0), (7.0E0,2.0E0),
237 + (7.0E0,2.0E0), (0.09E0,0.03E0), (5.0E0,8.0E0),
Austin Schuh189376f2018-12-20 22:11:15 +1100[diff] [blame]238 + (0.15E0,0.00E0), (6.0E0,9.0E0), (0.00E0,0.15E0),
239 + (8.0E0,3.0E0), (0.00E0,0.06E0), (9.0E0,4.0E0)/
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* .. SCNRM2 ..
252 CALL STEST1(SCNRM2(N,CX,INCX),STRUE2(NP1),STRUE2(NP1),
253 + SFAC)
254 ELSE IF (ICASE.EQ.7) THEN
255* .. SCASUM ..
256 CALL STEST1(SCASUM(N,CX,INCX),STRUE4(NP1),STRUE4(NP1),
257 + SFAC)
258 ELSE IF (ICASE.EQ.8) THEN
259* .. CSCAL ..
260 CALL CSCAL(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* .. CSSCAL ..
265 CALL CSSCAL(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* .. ICAMAX ..
270 CALL ITEST1(ICAMAX(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* CSCAL
282* Add a test for alpha equal to zero.
283 CA = (0.0E0,0.0E0)
284 DO 80 I = 1, 5
285 MWPCT(I) = (0.0E0,0.0E0)
286 MWPCS(I) = (1.0E0,1.0E0)
287 80 CONTINUE
288 CALL CSCAL(5,CA,CX,INCX)
289 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
290 ELSE IF (ICASE.EQ.9) THEN
291* CSSCAL
292* Add a test for alpha equal to zero.
293 SA = 0.0E0
294 DO 100 I = 1, 5
295 MWPCT(I) = (0.0E0,0.0E0)
296 MWPCS(I) = (1.0E0,1.0E0)
297 100 CONTINUE
298 CALL CSSCAL(5,SA,CX,INCX)
299 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
300* Add a test for alpha equal to one.
301 SA = 1.0E0
302 DO 120 I = 1, 5
303 MWPCT(I) = CX(I)
304 MWPCS(I) = CX(I)
305 120 CONTINUE
306 CALL CSSCAL(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.0E0
310 DO 140 I = 1, 5
311 MWPCT(I) = -CX(I)
312 MWPCS(I) = -CX(I)
313 140 CONTINUE
314 CALL CSSCAL(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 REAL SFAC
325* .. Scalars in Common ..
326 INTEGER ICASE, INCX, INCY, MODE, N
327 LOGICAL PASS
328* .. Local Scalars ..
329 COMPLEX CA
330 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
331* .. Local Arrays ..
332 COMPLEX 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 CDOTC, CDOTU
338 EXTERNAL CDOTC, CDOTU
339* .. External Subroutines ..
340 EXTERNAL CAXPY, CCOPY, CSWAP, 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.4E0,-0.7E0)/
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.7E0,-0.8E0), (-0.4E0,-0.7E0),
352 + (-0.1E0,-0.9E0), (0.2E0,-0.8E0),
353 + (-0.9E0,-0.4E0), (0.1E0,0.4E0), (-0.6E0,0.6E0)/
354 DATA CY1/(0.6E0,-0.6E0), (-0.9E0,0.5E0),
355 + (0.7E0,-0.6E0), (0.1E0,-0.5E0), (-0.1E0,-0.2E0),
356 + (-0.5E0,-0.3E0), (0.8E0,-0.7E0)/
357 DATA ((CT8(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0),
358 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
359 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
360 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
361 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
362 + (0.0E0,0.0E0), (0.32E0,-1.41E0),
363 + (-1.55E0,0.5E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
364 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
365 + (0.32E0,-1.41E0), (-1.55E0,0.5E0),
366 + (0.03E0,-0.89E0), (-0.38E0,-0.96E0),
367 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/
368 DATA ((CT8(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0),
369 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
370 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
371 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
372 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
373 + (0.0E0,0.0E0), (-0.07E0,-0.89E0),
374 + (-0.9E0,0.5E0), (0.42E0,-1.41E0), (0.0E0,0.0E0),
375 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
376 + (0.78E0,0.06E0), (-0.9E0,0.5E0),
377 + (0.06E0,-0.13E0), (0.1E0,-0.5E0),
378 + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0),
379 + (0.52E0,-1.51E0)/
380 DATA ((CT8(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0),
381 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
382 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
383 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
384 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
385 + (0.0E0,0.0E0), (-0.07E0,-0.89E0),
386 + (-1.18E0,-0.31E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
387 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
388 + (0.78E0,0.06E0), (-1.54E0,0.97E0),
389 + (0.03E0,-0.89E0), (-0.18E0,-1.31E0),
390 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/
391 DATA ((CT8(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0),
392 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
393 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
394 + (0.32E0,-1.41E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
395 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
396 + (0.0E0,0.0E0), (0.32E0,-1.41E0), (-0.9E0,0.5E0),
397 + (0.05E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
398 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.32E0,-1.41E0),
399 + (-0.9E0,0.5E0), (0.05E0,-0.6E0), (0.1E0,-0.5E0),
400 + (-0.77E0,-0.49E0), (-0.5E0,-0.3E0),
401 + (0.32E0,-1.16E0)/
402 DATA CT7/(0.0E0,0.0E0), (-0.06E0,-0.90E0),
403 + (0.65E0,-0.47E0), (-0.34E0,-1.22E0),
404 + (0.0E0,0.0E0), (-0.06E0,-0.90E0),
405 + (-0.59E0,-1.46E0), (-1.04E0,-0.04E0),
406 + (0.0E0,0.0E0), (-0.06E0,-0.90E0),
407 + (-0.83E0,0.59E0), (0.07E0,-0.37E0),
408 + (0.0E0,0.0E0), (-0.06E0,-0.90E0),
409 + (-0.76E0,-1.15E0), (-1.33E0,-1.82E0)/
410 DATA CT6/(0.0E0,0.0E0), (0.90E0,0.06E0),
411 + (0.91E0,-0.77E0), (1.80E0,-0.10E0),
412 + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.45E0,0.74E0),
413 + (0.20E0,0.90E0), (0.0E0,0.0E0), (0.90E0,0.06E0),
414 + (-0.55E0,0.23E0), (0.83E0,-0.39E0),
415 + (0.0E0,0.0E0), (0.90E0,0.06E0), (1.04E0,0.79E0),
416 + (1.95E0,1.22E0)/
417 DATA ((CT10X(I,J,1),I=1,7),J=1,4)/(0.7E0,-0.8E0),
418 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
419 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
420 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
421 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
422 + (0.0E0,0.0E0), (0.6E0,-0.6E0), (-0.9E0,0.5E0),
423 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
424 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0),
425 + (-0.9E0,0.5E0), (0.7E0,-0.6E0), (0.1E0,-0.5E0),
426 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/
427 DATA ((CT10X(I,J,2),I=1,7),J=1,4)/(0.7E0,-0.8E0),
428 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
429 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
430 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
431 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
432 + (0.0E0,0.0E0), (0.7E0,-0.6E0), (-0.4E0,-0.7E0),
433 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
434 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.8E0,-0.7E0),
435 + (-0.4E0,-0.7E0), (-0.1E0,-0.2E0),
436 + (0.2E0,-0.8E0), (0.7E0,-0.6E0), (0.1E0,0.4E0),
437 + (0.6E0,-0.6E0)/
438 DATA ((CT10X(I,J,3),I=1,7),J=1,4)/(0.7E0,-0.8E0),
439 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
440 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
441 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
442 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
443 + (0.0E0,0.0E0), (-0.9E0,0.5E0), (-0.4E0,-0.7E0),
444 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
445 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.1E0,-0.5E0),
446 + (-0.4E0,-0.7E0), (0.7E0,-0.6E0), (0.2E0,-0.8E0),
447 + (-0.9E0,0.5E0), (0.1E0,0.4E0), (0.6E0,-0.6E0)/
448 DATA ((CT10X(I,J,4),I=1,7),J=1,4)/(0.7E0,-0.8E0),
449 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
450 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
451 + (0.6E0,-0.6E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
452 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
453 + (0.0E0,0.0E0), (0.6E0,-0.6E0), (0.7E0,-0.6E0),
454 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
455 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.6E0,-0.6E0),
456 + (0.7E0,-0.6E0), (-0.1E0,-0.2E0), (0.8E0,-0.7E0),
457 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0)/
458 DATA ((CT10Y(I,J,1),I=1,7),J=1,4)/(0.6E0,-0.6E0),
459 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
460 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
461 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
462 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
463 + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.4E0,-0.7E0),
464 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
465 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0),
466 + (-0.4E0,-0.7E0), (-0.1E0,-0.9E0),
467 + (0.2E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
468 + (0.0E0,0.0E0)/
469 DATA ((CT10Y(I,J,2),I=1,7),J=1,4)/(0.6E0,-0.6E0),
470 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
471 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
472 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
473 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
474 + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (-0.9E0,0.5E0),
475 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
476 + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0),
477 + (-0.9E0,0.5E0), (-0.9E0,-0.4E0), (0.1E0,-0.5E0),
478 + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0),
479 + (0.7E0,-0.8E0)/
480 DATA ((CT10Y(I,J,3),I=1,7),J=1,4)/(0.6E0,-0.6E0),
481 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
482 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
483 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
484 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
485 + (0.0E0,0.0E0), (-0.1E0,-0.9E0), (0.7E0,-0.8E0),
486 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
487 + (0.0E0,0.0E0), (0.0E0,0.0E0), (-0.6E0,0.6E0),
488 + (-0.9E0,-0.4E0), (-0.1E0,-0.9E0),
489 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
490 + (0.0E0,0.0E0)/
491 DATA ((CT10Y(I,J,4),I=1,7),J=1,4)/(0.6E0,-0.6E0),
492 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
493 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
494 + (0.7E0,-0.8E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
495 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
496 + (0.0E0,0.0E0), (0.7E0,-0.8E0), (-0.9E0,0.5E0),
497 + (-0.4E0,-0.7E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
498 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.7E0,-0.8E0),
499 + (-0.9E0,0.5E0), (-0.4E0,-0.7E0), (0.1E0,-0.5E0),
500 + (-0.1E0,-0.9E0), (-0.5E0,-0.3E0),
501 + (0.2E0,-0.8E0)/
502 DATA CSIZE1/(0.0E0,0.0E0), (0.9E0,0.9E0),
503 + (1.63E0,1.73E0), (2.90E0,2.78E0)/
504 DATA CSIZE3/(0.0E0,0.0E0), (0.0E0,0.0E0),
505 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
506 + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.17E0,1.17E0),
507 + (1.17E0,1.17E0), (1.17E0,1.17E0),
508 + (1.17E0,1.17E0), (1.17E0,1.17E0),
509 + (1.17E0,1.17E0), (1.17E0,1.17E0)/
510 DATA CSIZE2/(0.0E0,0.0E0), (0.0E0,0.0E0),
511 + (0.0E0,0.0E0), (0.0E0,0.0E0), (0.0E0,0.0E0),
512 + (0.0E0,0.0E0), (0.0E0,0.0E0), (1.54E0,1.54E0),
513 + (1.54E0,1.54E0), (1.54E0,1.54E0),
514 + (1.54E0,1.54E0), (1.54E0,1.54E0),
515 + (1.54E0,1.54E0), (1.54E0,1.54E0)/
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* .. CDOTC ..
535 CDOT(1) = CDOTC(N,CX,INCX,CY,INCY)
536 CALL CTEST(1,CDOT,CT6(KN,KI),CSIZE1(KN),SFAC)
537 ELSE IF (ICASE.EQ.2) THEN
538* .. CDOTU ..
539 CDOT(1) = CDOTU(N,CX,INCX,CY,INCY)
540 CALL CTEST(1,CDOT,CT7(KN,KI),CSIZE1(KN),SFAC)
541 ELSE IF (ICASE.EQ.3) THEN
542* .. CAXPY ..
543 CALL CAXPY(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* .. CCOPY ..
547 CALL CCOPY(N,CX,INCX,CY,INCY)
548 CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0)
549 ELSE IF (ICASE.EQ.5) THEN
550* .. CSWAP ..
551 CALL CSWAP(N,CX,INCX,CY,INCY)
552 CALL CTEST(LENX,CX,CT10X(1,KN,KI),CSIZE3,1.0E0)
553 CALL CTEST(LENY,CY,CT10Y(1,KN,KI),CSIZE3,1.0E0)
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 REAL ZERO
575 PARAMETER (NOUT=6, ZERO=0.0E0)
Brian Silverman72890c22015-09-19 14:37:37 -0400[diff] [blame]576* .. Scalar Arguments ..
577 REAL SFAC
578 INTEGER LEN
579* .. Array Arguments ..
580 REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
581* .. Scalars in Common ..
582 INTEGER ICASE, INCX, INCY, MODE, N
583 LOGICAL PASS
584* .. Local Scalars ..
585 REAL SD
586 INTEGER I
587* .. External Functions ..
588 REAL 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,2E36.8,2E12.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 REAL SCOMP1, SFAC, STRUE1
630* .. Array Arguments ..
631 REAL SSIZE(*)
632* .. Local Arrays ..
633 REAL 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 REAL FUNCTION SDIFF(SA,SB)
645* ********************************* SDIFF **************************
646* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
647*
648* .. Scalar Arguments ..
649 REAL 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 REAL SFAC
661 INTEGER LEN
662* .. Array Arguments ..
663 COMPLEX CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
664* .. Local Scalars ..
665 INTEGER I
666* .. Local Arrays ..
667 REAL SCOMP(20), SSIZE(20), STRUE(20)
668* .. External Subroutines ..
669 EXTERNAL STEST
670* .. Intrinsic Functions ..
671 INTRINSIC AIMAG, REAL
672* .. Executable Statements ..
673 DO 20 I = 1, LEN
674 SCOMP(2*I-1) = REAL(CCOMP(I))
675 SCOMP(2*I) = AIMAG(CCOMP(I))
676 STRUE(2*I-1) = REAL(CTRUE(I))
677 STRUE(2*I) = AIMAG(CTRUE(I))
678 SSIZE(2*I-1) = REAL(CSIZE(I))
679 SSIZE(2*I) = AIMAG(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