OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zblat1.f File Reference

Go to the source code of this file.

Functions/Subroutines

program zblat1
 ZBLAT1
subroutine header
subroutine check1 (sfac)
subroutine check2 (sfac)
subroutine stest (len, scomp, strue, ssize, sfac)
subroutine stest1 (scomp1, strue1, ssize, sfac)
double precision function sdiff (sa, sb)
subroutine ctest (len, ccomp, ctrue, csize, sfac)
subroutine itest1 (icomp, itrue)

Function/Subroutine Documentation

◆ check1()

subroutine check1 ( double precision sfac)

Definition at line 121 of file zblat1.f.

122* .. Parameters ..
123 INTEGER NOUT
124 parameter(nout=6)
125* .. Scalar Arguments ..
126 DOUBLE PRECISION SFAC
127* .. Scalars in Common ..
128 INTEGER ICASE, INCX, INCY, MODE, N
129 LOGICAL PASS
130* .. Local Scalars ..
131 COMPLEX*16 CA
132 DOUBLE PRECISION SA
133 INTEGER I, IX, J, LEN, NP1
134* .. Local Arrays ..
135 COMPLEX*16 CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CVR(8),
136 + CX(8), CXR(15), MWPCS(5), MWPCT(5)
137 DOUBLE PRECISION STRUE2(5), STRUE4(5)
138 INTEGER ITRUE3(5), ITRUEC(5)
139* .. External Functions ..
140 DOUBLE PRECISION DZASUM, DZNRM2
141 INTEGER IZAMAX
142 EXTERNAL dzasum, dznrm2, izamax
143* .. External Subroutines ..
144 EXTERNAL zscal, zdscal, 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.3d0, (0.4d0,-0.7d0)/
151 DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
152 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
153 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
154 + (1.0d0,2.0d0), (0.3d0,-0.4d0), (3.0d0,4.0d0),
155 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
156 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
157 + (0.1d0,-0.3d0), (0.5d0,-0.1d0), (5.0d0,6.0d0),
158 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
159 + (5.0d0,6.0d0), (5.0d0,6.0d0), (0.1d0,0.1d0),
160 + (-0.6d0,0.1d0), (0.1d0,-0.3d0), (7.0d0,8.0d0),
161 + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
162 + (7.0d0,8.0d0), (0.3d0,0.1d0), (0.5d0,0.0d0),
163 + (0.0d0,0.5d0), (0.0d0,0.2d0), (2.0d0,3.0d0),
164 + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
165 DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
166 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
167 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
168 + (4.0d0,5.0d0), (0.3d0,-0.4d0), (6.0d0,7.0d0),
169 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
170 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
171 + (0.1d0,-0.3d0), (8.0d0,9.0d0), (0.5d0,-0.1d0),
172 + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
173 + (2.0d0,5.0d0), (2.0d0,5.0d0), (0.1d0,0.1d0),
174 + (3.0d0,6.0d0), (-0.6d0,0.1d0), (4.0d0,7.0d0),
175 + (0.1d0,-0.3d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
176 + (7.0d0,2.0d0), (0.3d0,0.1d0), (5.0d0,8.0d0),
177 + (0.5d0,0.0d0), (6.0d0,9.0d0), (0.0d0,0.5d0),
178 + (8.0d0,3.0d0), (0.0d0,0.2d0), (9.0d0,4.0d0)/
179 DATA cvr/(8.0d0,8.0d0), (-7.0d0,-7.0d0),
180 + (9.0d0,9.0d0), (5.0d0,5.0d0), (9.0d0,9.0d0),
181 + (8.0d0,8.0d0), (7.0d0,7.0d0), (7.0d0,7.0d0)/
182 DATA strue2/0.0d0, 0.5d0, 0.6d0, 0.7d0, 0.8d0/
183 DATA strue4/0.0d0, 0.7d0, 1.0d0, 1.3d0, 1.6d0/
184 DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
185 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
186 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
187 + (1.0d0,2.0d0), (-0.16d0,-0.37d0), (3.0d0,4.0d0),
188 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
189 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
190 + (-0.17d0,-0.19d0), (0.13d0,-0.39d0),
191 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
192 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
193 + (0.11d0,-0.03d0), (-0.17d0,0.46d0),
194 + (-0.17d0,-0.19d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
195 + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
196 + (0.19d0,-0.17d0), (0.20d0,-0.35d0),
197 + (0.35d0,0.20d0), (0.14d0,0.08d0),
198 + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0),
199 + (2.0d0,3.0d0)/
200 DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
201 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
202 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
203 + (4.0d0,5.0d0), (-0.16d0,-0.37d0), (6.0d0,7.0d0),
204 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
205 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
206 + (-0.17d0,-0.19d0), (8.0d0,9.0d0),
207 + (0.13d0,-0.39d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
208 + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
209 + (0.11d0,-0.03d0), (3.0d0,6.0d0),
210 + (-0.17d0,0.46d0), (4.0d0,7.0d0),
211 + (-0.17d0,-0.19d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
212 + (7.0d0,2.0d0), (0.19d0,-0.17d0), (5.0d0,8.0d0),
213 + (0.20d0,-0.35d0), (6.0d0,9.0d0),
214 + (0.35d0,0.20d0), (8.0d0,3.0d0),
215 + (0.14d0,0.08d0), (9.0d0,4.0d0)/
216 DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1d0,0.1d0),
217 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
218 + (1.0d0,2.0d0), (1.0d0,2.0d0), (1.0d0,2.0d0),
219 + (1.0d0,2.0d0), (0.09d0,-0.12d0), (3.0d0,4.0d0),
220 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
221 + (3.0d0,4.0d0), (3.0d0,4.0d0), (3.0d0,4.0d0),
222 + (0.03d0,-0.09d0), (0.15d0,-0.03d0),
223 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
224 + (5.0d0,6.0d0), (5.0d0,6.0d0), (5.0d0,6.0d0),
225 + (0.03d0,0.03d0), (-0.18d0,0.03d0),
226 + (0.03d0,-0.09d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
227 + (7.0d0,8.0d0), (7.0d0,8.0d0), (7.0d0,8.0d0),
228 + (0.09d0,0.03d0), (0.15d0,0.00d0),
229 + (0.00d0,0.15d0), (0.00d0,0.06d0), (2.0d0,3.0d0),
230 + (2.0d0,3.0d0), (2.0d0,3.0d0), (2.0d0,3.0d0)/
231 DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1d0,0.1d0),
232 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
233 + (4.0d0,5.0d0), (4.0d0,5.0d0), (4.0d0,5.0d0),
234 + (4.0d0,5.0d0), (0.09d0,-0.12d0), (6.0d0,7.0d0),
235 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
236 + (6.0d0,7.0d0), (6.0d0,7.0d0), (6.0d0,7.0d0),
237 + (0.03d0,-0.09d0), (8.0d0,9.0d0),
238 + (0.15d0,-0.03d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
239 + (2.0d0,5.0d0), (2.0d0,5.0d0), (2.0d0,5.0d0),
240 + (0.03d0,0.03d0), (3.0d0,6.0d0),
241 + (-0.18d0,0.03d0), (4.0d0,7.0d0),
242 + (0.03d0,-0.09d0), (7.0d0,2.0d0), (7.0d0,2.0d0),
243 + (7.0d0,2.0d0), (0.09d0,0.03d0), (5.0d0,8.0d0),
244 + (0.15d0,0.00d0), (6.0d0,9.0d0), (0.00d0,0.15d0),
245 + (8.0d0,3.0d0), (0.00d0,0.06d0), (9.0d0,4.0d0)/
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* .. DZNRM2 ..
259 CALL stest1(dznrm2(n,cx,incx),strue2(np1),strue2(np1),
260 + sfac)
261 ELSE IF (icase.EQ.7) THEN
262* .. DZASUM ..
263 CALL stest1(dzasum(n,cx,incx),strue4(np1),strue4(np1),
264 + sfac)
265 ELSE IF (icase.EQ.8) THEN
266* .. ZSCAL ..
267 CALL zscal(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* .. ZDSCAL ..
272 CALL zdscal(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* .. IZAMAX ..
277 CALL itest1(izamax(n,cx,incx),itrue3(np1))
278 DO 160 i = 1, len
279 cx(i) = (42.0d0,43.0d0)
280 160 CONTINUE
281 CALL itest1(izamax(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.EQ. IF (ICASE10) 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(IZAMAX(N,CXR,INCX),3)
296 END IF
297 60 CONTINUE
298*
299 INCX = 1
300.EQ. IF (ICASE8) THEN
301* ZSCAL
302* Add a test for alpha equal to zero.
303 CA = (0.0D0,0.0D0)
304 DO 80 I = 1, 5
305 MWPCT(I) = (0.0D0,0.0D0)
306 MWPCS(I) = (1.0D0,1.0D0)
307 80 CONTINUE
308 CALL ZSCAL(5,CA,CX,INCX)
309 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
310.EQ. ELSE IF (ICASE9) THEN
311* ZDSCAL
312* Add a test for alpha equal to zero.
313 SA = 0.0D0
314 DO 100 I = 1, 5
315 MWPCT(I) = (0.0D0,0.0D0)
316 MWPCS(I) = (1.0D0,1.0D0)
317 100 CONTINUE
318 CALL ZDSCAL(5,SA,CX,INCX)
319 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
320* Add a test for alpha equal to one.
321 SA = 1.0D0
322 DO 120 I = 1, 5
323 MWPCT(I) = CX(I)
324 MWPCS(I) = CX(I)
325 120 CONTINUE
326 CALL ZDSCAL(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.0D0
330 DO 140 I = 1, 5
331 MWPCT(I) = -CX(I)
332 MWPCS(I) = -CX(I)
333 140 CONTINUE
334 CALL ZDSCAL(5,SA,CX,INCX)
335 CALL CTEST(5,CX,MWPCT,MWPCS,SFAC)
336 END IF
337 RETURN
338*
339* End of CHECK1
340*
izamax
integer function izamax(n, zx, incx)
IZAMAX
Definition izamax.f:71
zdscal
subroutine zdscal(n, da, zx, incx)
ZDSCAL
Definition zdscal.f:78
zscal
subroutine zscal(n, za, zx, incx)
ZSCAL
Definition zscal.f:78
dzasum
double precision function dzasum(n, zx, incx)
DZASUM
Definition dzasum.f:72
dznrm2
real(wp) function dznrm2(n, x, incx)
DZNRM2
Definition dznrm2.f90:90
max
#define max(a, b)
Definition macros.h:21
ctest
subroutine ctest(len, ccomp, ctrue, csize, sfac)
Definition zblat1.f:709
stest1
subroutine stest1(scomp1, strue1, ssize, sfac)
Definition zblat1.f:668
itest1
subroutine itest1(icomp, itrue)
Definition zblat1.f:743
check1
subroutine check1(sfac)
Definition zblat1.f:122

◆ check2()

subroutine check2 ( double precision sfac)

Definition at line 342 of file zblat1.f.

343* .. Parameters ..
344 INTEGER NOUT
345 parameter(nout=6)
346* .. Scalar Arguments ..
347 DOUBLE PRECISION SFAC
348* .. Scalars in Common ..
349 INTEGER ICASE, INCX, INCY, MODE, N
350 LOGICAL PASS
351* .. Local Scalars ..
352 COMPLEX*16 CA
353 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
354 + MX, MY
355* .. Local Arrays ..
356 COMPLEX*16 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*16 ZDOTC, ZDOTU
363 EXTERNAL zdotc, zdotu
364* .. External Subroutines ..
365 EXTERNAL zaxpy, zcopy, zswap, 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.4d0,-0.7d0)/
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.7d0,-0.8d0), (-0.4d0,-0.7d0),
377 + (-0.1d0,-0.9d0), (0.2d0,-0.8d0),
378 + (-0.9d0,-0.4d0), (0.1d0,0.4d0), (-0.6d0,0.6d0)/
379 DATA cy1/(0.6d0,-0.6d0), (-0.9d0,0.5d0),
380 + (0.7d0,-0.6d0), (0.1d0,-0.5d0), (-0.1d0,-0.2d0),
381 + (-0.5d0,-0.3d0), (0.8d0,-0.7d0)/
382 DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
383 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
384 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
385 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
386 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
387 + (0.0d0,0.0d0), (0.32d0,-1.41d0),
388 + (-1.55d0,0.5d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
389 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
390 + (0.32d0,-1.41d0), (-1.55d0,0.5d0),
391 + (0.03d0,-0.89d0), (-0.38d0,-0.96d0),
392 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
393 DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
394 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
395 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
396 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
397 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
398 + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
399 + (-0.9d0,0.5d0), (0.42d0,-1.41d0), (0.0d0,0.0d0),
400 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
401 + (0.78d0,0.06d0), (-0.9d0,0.5d0),
402 + (0.06d0,-0.13d0), (0.1d0,-0.5d0),
403 + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
404 + (0.52d0,-1.51d0)/
405 DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
406 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
407 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
408 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
409 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
410 + (0.0d0,0.0d0), (-0.07d0,-0.89d0),
411 + (-1.18d0,-0.31d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
412 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
413 + (0.78d0,0.06d0), (-1.54d0,0.97d0),
414 + (0.03d0,-0.89d0), (-0.18d0,-1.31d0),
415 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
416 DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
417 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
418 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
419 + (0.32d0,-1.41d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
420 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
421 + (0.0d0,0.0d0), (0.32d0,-1.41d0), (-0.9d0,0.5d0),
422 + (0.05d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
423 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.32d0,-1.41d0),
424 + (-0.9d0,0.5d0), (0.05d0,-0.6d0), (0.1d0,-0.5d0),
425 + (-0.77d0,-0.49d0), (-0.5d0,-0.3d0),
426 + (0.32d0,-1.16d0)/
427 DATA ct7/(0.0d0,0.0d0), (-0.06d0,-0.90d0),
428 + (0.65d0,-0.47d0), (-0.34d0,-1.22d0),
429 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
430 + (-0.59d0,-1.46d0), (-1.04d0,-0.04d0),
431 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
432 + (-0.83d0,0.59d0), (0.07d0,-0.37d0),
433 + (0.0d0,0.0d0), (-0.06d0,-0.90d0),
434 + (-0.76d0,-1.15d0), (-1.33d0,-1.82d0)/
435 DATA ct6/(0.0d0,0.0d0), (0.90d0,0.06d0),
436 + (0.91d0,-0.77d0), (1.80d0,-0.10d0),
437 + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.45d0,0.74d0),
438 + (0.20d0,0.90d0), (0.0d0,0.0d0), (0.90d0,0.06d0),
439 + (-0.55d0,0.23d0), (0.83d0,-0.39d0),
440 + (0.0d0,0.0d0), (0.90d0,0.06d0), (1.04d0,0.79d0),
441 + (1.95d0,1.22d0)/
442 DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7d0,-0.8d0),
443 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
444 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
445 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
446 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
447 + (0.0d0,0.0d0), (0.6d0,-0.6d0), (-0.9d0,0.5d0),
448 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
449 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
450 + (-0.9d0,0.5d0), (0.7d0,-0.6d0), (0.1d0,-0.5d0),
451 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
452 DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7d0,-0.8d0),
453 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
454 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
455 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
456 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
457 + (0.0d0,0.0d0), (0.7d0,-0.6d0), (-0.4d0,-0.7d0),
458 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
459 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.8d0,-0.7d0),
460 + (-0.4d0,-0.7d0), (-0.1d0,-0.2d0),
461 + (0.2d0,-0.8d0), (0.7d0,-0.6d0), (0.1d0,0.4d0),
462 + (0.6d0,-0.6d0)/
463 DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7d0,-0.8d0),
464 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
465 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
466 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
467 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
468 + (0.0d0,0.0d0), (-0.9d0,0.5d0), (-0.4d0,-0.7d0),
469 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
470 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.1d0,-0.5d0),
471 + (-0.4d0,-0.7d0), (0.7d0,-0.6d0), (0.2d0,-0.8d0),
472 + (-0.9d0,0.5d0), (0.1d0,0.4d0), (0.6d0,-0.6d0)/
473 DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7d0,-0.8d0),
474 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
475 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
476 + (0.6d0,-0.6d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
477 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
478 + (0.0d0,0.0d0), (0.6d0,-0.6d0), (0.7d0,-0.6d0),
479 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
480 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.6d0,-0.6d0),
481 + (0.7d0,-0.6d0), (-0.1d0,-0.2d0), (0.8d0,-0.7d0),
482 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0)/
483 DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6d0,-0.6d0),
484 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
485 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
486 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
487 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
488 + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.4d0,-0.7d0),
489 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
490 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
491 + (-0.4d0,-0.7d0), (-0.1d0,-0.9d0),
492 + (0.2d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
493 + (0.0d0,0.0d0)/
494 DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6d0,-0.6d0),
495 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
496 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
497 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
498 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
499 + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (-0.9d0,0.5d0),
500 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
501 + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
502 + (-0.9d0,0.5d0), (-0.9d0,-0.4d0), (0.1d0,-0.5d0),
503 + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
504 + (0.7d0,-0.8d0)/
505 DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6d0,-0.6d0),
506 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
507 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
508 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
509 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
510 + (0.0d0,0.0d0), (-0.1d0,-0.9d0), (0.7d0,-0.8d0),
511 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
512 + (0.0d0,0.0d0), (0.0d0,0.0d0), (-0.6d0,0.6d0),
513 + (-0.9d0,-0.4d0), (-0.1d0,-0.9d0),
514 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
515 + (0.0d0,0.0d0)/
516 DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6d0,-0.6d0),
517 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
518 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
519 + (0.7d0,-0.8d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
520 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
521 + (0.0d0,0.0d0), (0.7d0,-0.8d0), (-0.9d0,0.5d0),
522 + (-0.4d0,-0.7d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
523 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.7d0,-0.8d0),
524 + (-0.9d0,0.5d0), (-0.4d0,-0.7d0), (0.1d0,-0.5d0),
525 + (-0.1d0,-0.9d0), (-0.5d0,-0.3d0),
526 + (0.2d0,-0.8d0)/
527 DATA csize1/(0.0d0,0.0d0), (0.9d0,0.9d0),
528 + (1.63d0,1.73d0), (2.90d0,2.78d0)/
529 DATA csize3/(0.0d0,0.0d0), (0.0d0,0.0d0),
530 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
531 + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.17d0,1.17d0),
532 + (1.17d0,1.17d0), (1.17d0,1.17d0),
533 + (1.17d0,1.17d0), (1.17d0,1.17d0),
534 + (1.17d0,1.17d0), (1.17d0,1.17d0)/
535 DATA csize2/(0.0d0,0.0d0), (0.0d0,0.0d0),
536 + (0.0d0,0.0d0), (0.0d0,0.0d0), (0.0d0,0.0d0),
537 + (0.0d0,0.0d0), (0.0d0,0.0d0), (1.54d0,1.54d0),
538 + (1.54d0,1.54d0), (1.54d0,1.54d0),
539 + (1.54d0,1.54d0), (1.54d0,1.54d0),
540 + (1.54d0,1.54d0), (1.54d0,1.54d0)/
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* .. ZDOTC ..
560 cdot(1) = zdotc(n,cx,incx,cy,incy)
561 CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
562 ELSE IF (icase.EQ.2) THEN
563* .. ZDOTU ..
564 cdot(1) = zdotu(n,cx,incx,cy,incy)
565 CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
566 ELSE IF (icase.EQ.3) THEN
567* .. ZAXPY ..
568 CALL zaxpy(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* .. ZCOPY ..
572 CALL zcopy(n,cx,incx,cy,incy)
573 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
574 IF (ki.EQ.1) THEN
575 cx0(1) = (42.0d0,43.0d0)
576 cy0(1) = (44.0d0,45.0d0)
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 zcopy(n,cx0,incx,cy0,incy)
587 CALL ctest(1,cy0,cty0,csize3,1.0d0)
588 incx = lincx
589 incy = lincy
590 END IF
591 ELSE IF (icase.EQ.5) THEN
592* .. ZSWAP ..
593 CALL zswap(n,cx,incx,cy,incy)
594 CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0d0)
595 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0d0)
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*
zdotc
complex *16 function zdotc(n, zx, incx, zy, incy)
ZDOTC
Definition zdotc.f:83
zdotu
complex *16 function zdotu(n, zx, incx, zy, incy)
ZDOTU
Definition zdotu.f:83
zswap
subroutine zswap(n, zx, incx, zy, incy)
ZSWAP
Definition zswap.f:81
zcopy
subroutine zcopy(n, zx, incx, zy, incy)
ZCOPY
Definition zcopy.f:81
zaxpy
subroutine zaxpy(n, za, zx, incx, zy, incy)
ZAXPY
Definition zaxpy.f:88
min
#define min(a, b)
Definition macros.h:20

◆ ctest()

subroutine ctest ( integer len,
complex*16, dimension(len) ccomp,
complex*16, dimension(len) ctrue,
complex*16, dimension(len) csize,
double precision sfac )

Definition at line 708 of file zblat1.f.

709* **************************** CTEST *****************************
710*
711* C.L. LAWSON, JPL, 1978 DEC 6
712*
713* .. Scalar Arguments ..
714 DOUBLE PRECISION SFAC
715 INTEGER LEN
716* .. Array Arguments ..
717 COMPLEX*16 CCOMP(LEN), CSIZE(LEN), CTRUE(LEN)
718* .. Local Scalars ..
719 INTEGER I
720* .. Local Arrays ..
721 DOUBLE PRECISION SCOMP(20), SSIZE(20), STRUE(20)
722* .. External Subroutines ..
723 EXTERNAL stest
724* .. Intrinsic Functions ..
725 INTRINSIC dimag, dble
726* .. Executable Statements ..
727 DO 20 i = 1, len
728 scomp(2*i-1) = dble(ccomp(i))
729 scomp(2*i) = dimag(ccomp(i))
730 strue(2*i-1) = dble(ctrue(i))
731 strue(2*i) = dimag(ctrue(i))
732 ssize(2*i-1) = dble(csize(i))
733 ssize(2*i) = dimag(csize(i))
734 20 CONTINUE
735*
736 CALL stest(2*len,scomp,strue,ssize,sfac)
737 RETURN
738*
739* End of CTEST
740*
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition zblat1.f:609

◆ header()

subroutine header

Definition at line 90 of file zblat1.f.

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*
118* End of HEADER
119*

◆ itest1()

subroutine itest1 ( integer icomp,
integer itrue )

Definition at line 742 of file zblat1.f.

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*
77699999 FORMAT (' FAIL')
77799998 FORMAT (/' CASE N INCX INCY MODE ',
778 + ' COMP TRUE DIFFERENCE',
779 + /1x)
78099997 FORMAT (1x,i4,i3,3i5,2i36,i12)
781*
782* End of ITEST1
783*
id
initmumps id
Definition multiplerhs_example.m:4

◆ sdiff()

double precision function sdiff ( double precision sa,
double precision sb )

Definition at line 695 of file zblat1.f.

696* ********************************* SDIFF **************************
697* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
698*
699* .. Scalar Arguments ..
700 DOUBLE PRECISION SA, SB
701* .. Executable Statements ..
702 sdiff = sa - sb
703 RETURN
704*
705* End of SDIFF
706*
sdiff
double precision function sdiff(sa, sb)
Definition zblat1.f:696

◆ stest()

subroutine stest ( integer len,
double precision, dimension(len) scomp,
double precision, dimension(len) strue,
double precision, dimension(len) ssize,
double precision sfac )

Definition at line 608 of file zblat1.f.

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 DOUBLE PRECISION ZERO
620 parameter(nout=6, zero=0.0d0)
621* .. Scalar Arguments ..
622 DOUBLE PRECISION SFAC
623 INTEGER LEN
624* .. Array Arguments ..
625 DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
626* .. Scalars in Common ..
627 INTEGER ICASE, INCX, INCY, MODE, N
628 LOGICAL PASS
629* .. Local Scalars ..
630 DOUBLE PRECISION SD
631 INTEGER I
632* .. External Functions ..
633 DOUBLE PRECISION 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*
65899999 FORMAT (' FAIL')
65999998 FORMAT (/' CASE N INCX INCY MODE I ',
660 + ' COMP(I) TRUE(I) DIFFERENCE',
661 + ' SIZE(I)',/1x)
66299997 FORMAT (1x,i4,i3,3i5,i3,2d36.8,2d12.4)
663*
664* End of STEST
665*

◆ stest1()

subroutine stest1 ( double precision scomp1,
double precision strue1,
double precision, dimension(*) ssize,
double precision sfac )

Definition at line 667 of file zblat1.f.

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 DOUBLE PRECISION SCOMP1, SFAC, STRUE1
678* .. Array Arguments ..
679 DOUBLE PRECISION SSIZE(*)
680* .. Local Arrays ..
681 DOUBLE PRECISION 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*