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

Go to the source code of this file.

Functions/Subroutines

program dblat1
 DBLAT1
subroutine header
subroutine check0 (sfac)
subroutine check1 (sfac)
subroutine check2 (sfac)
subroutine check3 (sfac)
subroutine stest (len, scomp, strue, ssize, sfac)
subroutine testdsdot (scomp, strue, ssize, sfac)
subroutine stest1 (scomp1, strue1, ssize, sfac)
double precision function sdiff (sa, sb)
subroutine itest1 (icomp, itrue)

Function/Subroutine Documentation

◆ check0()

subroutine check0 ( double precision sfac)

Definition at line 129 of file dblat1.f.

130* .. Parameters ..
131 INTEGER NOUT
132 parameter(nout=6)
133* .. Scalar Arguments ..
134 DOUBLE PRECISION SFAC
135* .. Scalars in Common ..
136 INTEGER ICASE, INCX, INCY, N
137 LOGICAL PASS
138* .. Local Scalars ..
139 DOUBLE PRECISION SA, SB, SC, SS, D12
140 INTEGER I, K
141* .. Local Arrays ..
142 DOUBLE PRECISION DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
143 $ DS1(8), DAB(4,9), DTEMP(9), DTRUE(9,9)
144* .. External Subroutines ..
145 EXTERNAL drotg, drotmg, stest, stest1
146* .. Common blocks ..
147 COMMON /combla/icase, n, incx, incy, pass
148* .. Data statements ..
149 DATA da1/0.3d0, 0.4d0, -0.3d0, -0.4d0, -0.3d0, 0.0d0,
150 + 0.0d0, 1.0d0/
151 DATA db1/0.4d0, 0.3d0, 0.4d0, 0.3d0, -0.4d0, 0.0d0,
152 + 1.0d0, 0.0d0/
153 DATA dc1/0.6d0, 0.8d0, -0.6d0, 0.8d0, 0.6d0, 1.0d0,
154 + 0.0d0, 1.0d0/
155 DATA ds1/0.8d0, 0.6d0, 0.8d0, -0.6d0, 0.8d0, 0.0d0,
156 + 1.0d0, 0.0d0/
157 DATA datrue/0.5d0, 0.5d0, 0.5d0, -0.5d0, -0.5d0,
158 + 0.0d0, 1.0d0, 1.0d0/
159 DATA dbtrue/0.0d0, 0.6d0, 0.0d0, -0.6d0, 0.0d0,
160 + 0.0d0, 1.0d0, 0.0d0/
161* INPUT FOR MODIFIED GIVENS
162 DATA dab/ .1d0,.3d0,1.2d0,.2d0,
163 a .7d0, .2d0, .6d0, 4.2d0,
164 b 0.d0,0.d0,0.d0,0.d0,
165 c 4.d0, -1.d0, 2.d0, 4.d0,
166 d 6.d-10, 2.d-2, 1.d5, 10.d0,
167 e 4.d10, 2.d-2, 1.d-5, 10.d0,
168 f 2.d-10, 4.d-2, 1.d5, 10.d0,
169 g 2.d10, 4.d-2, 1.d-5, 10.d0,
170 h 4.d0, -2.d0, 8.d0, 4.d0 /
171* TRUE RESULTS FOR MODIFIED GIVENS
172 DATA dtrue/0.d0,0.d0, 1.3d0, .2d0, 0.d0,0.d0,0.d0, .5d0, 0.d0,
173 a 0.d0,0.d0, 4.5d0, 4.2d0, 1.d0, .5d0, 0.d0,0.d0,0.d0,
174 b 0.d0,0.d0,0.d0,0.d0, -2.d0, 0.d0,0.d0,0.d0,0.d0,
175 c 0.d0,0.d0,0.d0, 4.d0, -1.d0, 0.d0,0.d0,0.d0,0.d0,
176 d 0.d0, 15.d-3, 0.d0, 10.d0, -1.d0, 0.d0, -1.d-4,
177 e 0.d0, 1.d0,
178 f 0.d0,0.d0, 6144.d-5, 10.d0, -1.d0, 4096.d0, -1.d6,
179 g 0.d0, 1.d0,
180 h 0.d0,0.d0,15.d0,10.d0,-1.d0, 5.d-5, 0.d0,1.d0,0.d0,
181 i 0.d0,0.d0, 15.d0, 10.d0, -1. d0, 5.d5, -4096.d0,
182 j 1.d0, 4096.d-6,
183 k 0.d0,0.d0, 7.d0, 4.d0, 0.d0,0.d0, -.5d0, -.25d0, 0.d0/
184* 4096 = 2 ** 12
185 DATA d12 /4096.d0/
186 dtrue(1,1) = 12.d0 / 130.d0
187 dtrue(2,1) = 36.d0 / 130.d0
188 dtrue(7,1) = -1.d0 / 6.d0
189 dtrue(1,2) = 14.d0 / 75.d0
190 dtrue(2,2) = 49.d0 / 75.d0
191 dtrue(9,2) = 1.d0 / 7.d0
192 dtrue(1,5) = 45.d-11 * (d12 * d12)
193 dtrue(3,5) = 4.d5 / (3.d0 * d12)
194 dtrue(6,5) = 1.d0 / d12
195 dtrue(8,5) = 1.d4 / (3.d0 * d12)
196 dtrue(1,6) = 4.d10 / (1.5d0 * d12 * d12)
197 dtrue(2,6) = 2.d-2 / 1.5d0
198 dtrue(8,6) = 5.d-7 * d12
199 dtrue(1,7) = 4.d0 / 150.d0
200 dtrue(2,7) = (2.d-10 / 1.5d0) * (d12 * d12)
201 dtrue(7,7) = -dtrue(6,5)
202 dtrue(9,7) = 1.d4 / d12
203 dtrue(1,8) = dtrue(1,7)
204 dtrue(2,8) = 2.d10 / (1.5d0 * d12 * d12)
205 dtrue(1,9) = 32.d0 / 7.d0
206 dtrue(2,9) = -16.d0 / 7.d0
207* .. Executable Statements ..
208*
209* Compute true values which cannot be prestored
210* in decimal notation
211*
212 dbtrue(1) = 1.0d0/0.6d0
213 dbtrue(3) = -1.0d0/0.6d0
214 dbtrue(5) = 1.0d0/0.6d0
215*
216 DO 20 k = 1, 8
217* .. Set N=K for identification in output if any ..
218 n = k
219 IF (icase.EQ.3) THEN
220* .. DROTG ..
221 IF (k.GT.8) GO TO 40
222 sa = da1(k)
223 sb = db1(k)
224 CALL drotg(sa,sb,sc,ss)
225 CALL stest1(sa,datrue(k),datrue(k),sfac)
226 CALL stest1(sb,dbtrue(k),dbtrue(k),sfac)
227 CALL stest1(sc,dc1(k),dc1(k),sfac)
228 CALL stest1(ss,ds1(k),ds1(k),sfac)
229 ELSEIF (icase.EQ.11) THEN
230* .. DROTMG ..
231 DO i=1,4
232 dtemp(i)= dab(i,k)
233 dtemp(i+4) = 0.0
234 END DO
235 dtemp(9) = 0.0
236 CALL drotmg(dtemp(1),dtemp(2),dtemp(3),dtemp(4),dtemp(5))
237 CALL stest(9,dtemp,dtrue(1,k),dtrue(1,k),sfac)
238 ELSE
239 WRITE (nout,*) ' Shouldn''t be here in CHECK0'
240 stop
241 END IF
242 20 CONTINUE
243 40 RETURN
244*
245* End of CHECK0
246*
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition dblat1.f:938
stest1
subroutine stest1(scomp1, strue1, ssize, sfac)
Definition dblat1.f:1048
drotmg
subroutine drotmg(dd1, dd2, dx1, dy1, dparam)
DROTMG
Definition drotmg.f:90
drotg
subroutine drotg(a, b, c, s)
DROTG
Definition drotg.f90:93

◆ check1()

subroutine check1 ( double precision sfac)

Definition at line 248 of file dblat1.f.

249* .. Parameters ..
250 INTEGER NOUT
251 parameter(nout=6)
252* .. Scalar Arguments ..
253 DOUBLE PRECISION SFAC
254* .. Scalars in Common ..
255 INTEGER ICASE, INCX, INCY, N
256 LOGICAL PASS
257* .. Local Scalars ..
258 INTEGER I, IX, LEN, NP1
259* .. Local Arrays ..
260 DOUBLE PRECISION DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
261 + DVR(8), SA(10), STEMP(1), STRUE(8), SX(8),
262 + SXR(15)
263 INTEGER ITRUE2(5), ITRUEC(5)
264* .. External Functions ..
265 DOUBLE PRECISION DASUM, DNRM2
266 INTEGER IDAMAX
267 EXTERNAL dasum, dnrm2, idamax
268* .. External Subroutines ..
269 EXTERNAL itest1, dscal, stest, stest1
270* .. Intrinsic Functions ..
271 INTRINSIC max
272* .. Common blocks ..
273 COMMON /combla/icase, n, incx, incy, pass
274* .. Data statements ..
275 DATA sa/0.3d0, -1.0d0, 0.0d0, 1.0d0, 0.3d0, 0.3d0,
276 + 0.3d0, 0.3d0, 0.3d0, 0.3d0/
277 DATA dv/0.1d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0,
278 + 2.0d0, 2.0d0, 0.3d0, 3.0d0, 3.0d0, 3.0d0, 3.0d0,
279 + 3.0d0, 3.0d0, 3.0d0, 0.3d0, -0.4d0, 4.0d0,
280 + 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 0.2d0,
281 + -0.6d0, 0.3d0, 5.0d0, 5.0d0, 5.0d0, 5.0d0,
282 + 5.0d0, 0.1d0, -0.3d0, 0.5d0, -0.1d0, 6.0d0,
283 + 6.0d0, 6.0d0, 6.0d0, 0.1d0, 8.0d0, 8.0d0, 8.0d0,
284 + 8.0d0, 8.0d0, 8.0d0, 8.0d0, 0.3d0, 9.0d0, 9.0d0,
285 + 9.0d0, 9.0d0, 9.0d0, 9.0d0, 9.0d0, 0.3d0, 2.0d0,
286 + -0.4d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0,
287 + 0.2d0, 3.0d0, -0.6d0, 5.0d0, 0.3d0, 2.0d0,
288 + 2.0d0, 2.0d0, 0.1d0, 4.0d0, -0.3d0, 6.0d0,
289 + -0.5d0, 7.0d0, -0.1d0, 3.0d0/
290 DATA dvr/8.0d0, -7.0d0, 9.0d0, 5.0d0, 9.0d0, 8.0d0,
291 + 7.0d0, 7.0d0/
292 DATA dtrue1/0.0d0, 0.3d0, 0.5d0, 0.7d0, 0.6d0/
293 DATA dtrue3/0.0d0, 0.3d0, 0.7d0, 1.1d0, 1.0d0/
294 DATA dtrue5/0.10d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0,
295 + 2.0d0, 2.0d0, 2.0d0, -0.3d0, 3.0d0, 3.0d0,
296 + 3.0d0, 3.0d0, 3.0d0, 3.0d0, 3.0d0, 0.0d0, 0.0d0,
297 + 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0,
298 + 0.20d0, -0.60d0, 0.30d0, 5.0d0, 5.0d0, 5.0d0,
299 + 5.0d0, 5.0d0, 0.03d0, -0.09d0, 0.15d0, -0.03d0,
300 + 6.0d0, 6.0d0, 6.0d0, 6.0d0, 0.10d0, 8.0d0,
301 + 8.0d0, 8.0d0, 8.0d0, 8.0d0, 8.0d0, 8.0d0,
302 + 0.09d0, 9.0d0, 9.0d0, 9.0d0, 9.0d0, 9.0d0,
303 + 9.0d0, 9.0d0, 0.09d0, 2.0d0, -0.12d0, 2.0d0,
304 + 2.0d0, 2.0d0, 2.0d0, 2.0d0, 0.06d0, 3.0d0,
305 + -0.18d0, 5.0d0, 0.09d0, 2.0d0, 2.0d0, 2.0d0,
306 + 0.03d0, 4.0d0, -0.09d0, 6.0d0, -0.15d0, 7.0d0,
307 + -0.03d0, 3.0d0/
308 DATA itrue2/0, 1, 2, 2, 3/
309 DATA itruec/0, 1, 1, 1, 1/
310* .. Executable Statements ..
311 DO 80 incx = 1, 2
312 DO 60 np1 = 1, 5
313 n = np1 - 1
314 len = 2*max(n,1)
315* .. Set vector arguments ..
316 DO 20 i = 1, len
317 sx(i) = dv(i,np1,incx)
318 20 CONTINUE
319*
320 IF (icase.EQ.7) THEN
321* .. DNRM2 ..
322 stemp(1) = dtrue1(np1)
323 CALL stest1(dnrm2(n,sx,incx),stemp(1),stemp,sfac)
324 ELSE IF (icase.EQ.8) THEN
325* .. DASUM ..
326 stemp(1) = dtrue3(np1)
327 CALL stest1(dasum(n,sx,incx),stemp(1),stemp,sfac)
328 ELSE IF (icase.EQ.9) THEN
329* .. DSCAL ..
330 CALL dscal(n,sa((incx-1)*5+np1),sx,incx)
331 DO 40 i = 1, len
332 strue(i) = dtrue5(i,np1,incx)
333 40 CONTINUE
334 CALL stest(len,sx,strue,strue,sfac)
335 ELSE IF (icase.EQ.10) THEN
336* .. IDAMAX ..
337 CALL itest1(idamax(n,sx,incx),itrue2(np1))
338 DO 100 i = 1, len
339 sx(i) = 42.0d0
340 100 CONTINUE
341 CALL itest1(idamax(n,sx,incx),itruec(np1))
342 ELSE
343 WRITE (nout,*) ' Shouldn''t be here in CHECK1'
344 stop
345 END IF
346 60 CONTINUE
347 IF (icase.EQ.10) THEN
348 n = 8
349 ix = 1
350 DO 120 i = 1, n
351 sxr(ix) = dvr(i)
352 ix = ix + incx
353 120 CONTINUE
354 CALL itest1(idamax(n,sxr,incx),3)
355 END IF
356 80 CONTINUE
357 RETURN
358*
359* End of CHECK1
360*
itest1
subroutine itest1(icomp, itrue)
Definition dblat1.f:1089
idamax
integer function idamax(n, dx, incx)
IDAMAX
Definition idamax.f:71
dscal
subroutine dscal(n, da, dx, incx)
DSCAL
Definition dscal.f:79
dasum
double precision function dasum(n, dx, incx)
DASUM
Definition dasum.f:71
dnrm2
real(wp) function dnrm2(n, x, incx)
DNRM2
Definition dnrm2.f90:89
max
#define max(a, b)
Definition macros.h:21

◆ check2()

subroutine check2 ( double precision sfac)

Definition at line 362 of file dblat1.f.

363* .. Parameters ..
364 INTEGER NOUT
365 parameter(nout=6)
366* .. Scalar Arguments ..
367 DOUBLE PRECISION SFAC
368* .. Scalars in Common ..
369 INTEGER ICASE, INCX, INCY, N
370 LOGICAL PASS
371* .. Local Scalars ..
372 DOUBLE PRECISION SA
373 INTEGER I, J, KI, KN, KNI, KPAR, KSIZE, LENX, LENY,
374 $ LINCX, LINCY, MX, MY
375* .. Local Arrays ..
376 DOUBLE PRECISION DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
377 $ DT8(7,4,4), DX1(7),
378 $ DY1(7), SSIZE1(4), SSIZE2(14,2), SSIZE(7),
379 $ STX(7), STY(7), SX(7), SY(7),
380 $ DPAR(5,4), DT19X(7,4,16),DT19XA(7,4,4),
381 $ DT19XB(7,4,4), DT19XC(7,4,4),DT19XD(7,4,4),
382 $ DT19Y(7,4,16), DT19YA(7,4,4),DT19YB(7,4,4),
383 $ DT19YC(7,4,4), DT19YD(7,4,4), DTEMP(5),
384 $ STY0(1), SX0(1), SY0(1)
385 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
386* .. External Functions ..
387 DOUBLE PRECISION DDOT, DSDOT
388 EXTERNAL ddot, dsdot
389* .. External Subroutines ..
390 EXTERNAL daxpy, dcopy, drotm, dswap, stest, stest1,
391 $ testdsdot
392* .. Intrinsic Functions ..
393 INTRINSIC abs, min
394* .. Common blocks ..
395 COMMON /combla/icase, n, incx, incy, pass
396* .. Data statements ..
397 equivalence(dt19x(1,1,1),dt19xa(1,1,1)),(dt19x(1,1,5),
398 a dt19xb(1,1,1)),(dt19x(1,1,9),dt19xc(1,1,1)),
399 b(dt19x(1,1,13),dt19xd(1,1,1))
400 equivalence(dt19y(1,1,1),dt19ya(1,1,1)),(dt19y(1,1,5),
401 a dt19yb(1,1,1)),(dt19y(1,1,9),dt19yc(1,1,1)),
402 b(dt19y(1,1,13),dt19yd(1,1,1))
403
404 DATA sa/0.3d0/
405 DATA incxs/1, 2, -2, -1/
406 DATA incys/1, -2, 1, -2/
407 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
408 DATA ns/0, 1, 2, 4/
409 DATA dx1/0.6d0, 0.1d0, -0.5d0, 0.8d0, 0.9d0, -0.3d0,
410 + -0.4d0/
411 DATA dy1/0.5d0, -0.9d0, 0.3d0, 0.7d0, -0.6d0, 0.2d0,
412 + 0.8d0/
413 DATA dt7/0.0d0, 0.30d0, 0.21d0, 0.62d0, 0.0d0,
414 + 0.30d0, -0.07d0, 0.85d0, 0.0d0, 0.30d0, -0.79d0,
415 + -0.74d0, 0.0d0, 0.30d0, 0.33d0, 1.27d0/
416 DATA dt8/0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
417 + 0.0d0, 0.68d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
418 + 0.0d0, 0.0d0, 0.68d0, -0.87d0, 0.0d0, 0.0d0,
419 + 0.0d0, 0.0d0, 0.0d0, 0.68d0, -0.87d0, 0.15d0,
420 + 0.94d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0,
421 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.68d0,
422 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
423 + 0.35d0, -0.9d0, 0.48d0, 0.0d0, 0.0d0, 0.0d0,
424 + 0.0d0, 0.38d0, -0.9d0, 0.57d0, 0.7d0, -0.75d0,
425 + 0.2d0, 0.98d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0,
426 + 0.0d0, 0.0d0, 0.0d0, 0.68d0, 0.0d0, 0.0d0,
427 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.35d0, -0.72d0,
428 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.38d0,
429 + -0.63d0, 0.15d0, 0.88d0, 0.0d0, 0.0d0, 0.0d0,
430 + 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
431 + 0.68d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
432 + 0.0d0, 0.68d0, -0.9d0, 0.33d0, 0.0d0, 0.0d0,
433 + 0.0d0, 0.0d0, 0.68d0, -0.9d0, 0.33d0, 0.7d0,
434 + -0.75d0, 0.2d0, 1.04d0/
435 DATA dt10x/0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
436 + 0.0d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
437 + 0.0d0, 0.5d0, -0.9d0, 0.0d0, 0.0d0, 0.0d0,
438 + 0.0d0, 0.0d0, 0.5d0, -0.9d0, 0.3d0, 0.7d0,
439 + 0.0d0, 0.0d0, 0.0d0, 0.6d0, 0.0d0, 0.0d0, 0.0d0,
440 + 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0,
441 + 0.0d0, 0.0d0, 0.0d0, 0.3d0, 0.1d0, 0.5d0, 0.0d0,
442 + 0.0d0, 0.0d0, 0.0d0, 0.8d0, 0.1d0, -0.6d0,
443 + 0.8d0, 0.3d0, -0.3d0, 0.5d0, 0.6d0, 0.0d0,
444 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0,
445 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, -0.9d0,
446 + 0.1d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.7d0,
447 + 0.1d0, 0.3d0, 0.8d0, -0.9d0, -0.3d0, 0.5d0,
448 + 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
449 + 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
450 + 0.5d0, 0.3d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
451 + 0.5d0, 0.3d0, -0.6d0, 0.8d0, 0.0d0, 0.0d0,
452 + 0.0d0/
453 DATA dt10y/0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
454 + 0.0d0, 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
455 + 0.0d0, 0.6d0, 0.1d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
456 + 0.0d0, 0.6d0, 0.1d0, -0.5d0, 0.8d0, 0.0d0,
457 + 0.0d0, 0.0d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
458 + 0.0d0, 0.0d0, 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
459 + 0.0d0, 0.0d0, -0.5d0, -0.9d0, 0.6d0, 0.0d0,
460 + 0.0d0, 0.0d0, 0.0d0, -0.4d0, -0.9d0, 0.9d0,
461 + 0.7d0, -0.5d0, 0.2d0, 0.6d0, 0.5d0, 0.0d0,
462 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.6d0, 0.0d0,
463 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, -0.5d0,
464 + 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
465 + -0.4d0, 0.9d0, -0.5d0, 0.6d0, 0.0d0, 0.0d0,
466 + 0.0d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
467 + 0.0d0, 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
468 + 0.0d0, 0.6d0, -0.9d0, 0.1d0, 0.0d0, 0.0d0,
469 + 0.0d0, 0.0d0, 0.6d0, -0.9d0, 0.1d0, 0.7d0,
470 + -0.5d0, 0.2d0, 0.8d0/
471 DATA ssize1/0.0d0, 0.3d0, 1.6d0, 3.2d0/
472 DATA ssize2/0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
473 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
474 + 0.0d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
475 + 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
476 + 1.17d0, 1.17d0, 1.17d0/
477*
478* FOR DROTM
479*
480 DATA dpar/-2.d0, 0.d0,0.d0,0.d0,0.d0,
481 a -1.d0, 2.d0, -3.d0, -4.d0, 5.d0,
482 b 0.d0, 0.d0, 2.d0, -3.d0, 0.d0,
483 c 1.d0, 5.d0, 2.d0, 0.d0, -4.d0/
484* TRUE X RESULTS F0R ROTATIONS DROTM
485 DATA dt19xa/.6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
486 a .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
487 b .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
488 c .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
489 d .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
490 e -.8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
491 f -.9d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
492 g 3.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
493 h .6d0, .1d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
494 i -.8d0, 3.8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
495 j -.9d0, 2.8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
496 k 3.5d0, -.4d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
497 l .6d0, .1d0, -.5d0, .8d0, 0.d0,0.d0,0.d0,
498 m -.8d0, 3.8d0, -2.2d0, -1.2d0, 0.d0,0.d0,0.d0,
499 n -.9d0, 2.8d0, -1.4d0, -1.3d0, 0.d0,0.d0,0.d0,
500 o 3.5d0, -.4d0, -2.2d0, 4.7d0, 0.d0,0.d0,0.d0/
501*
502 DATA dt19xb/.6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
503 a .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
504 b .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
505 c .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
506 d .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
507 e -.8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
508 f -.9d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
509 g 3.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
510 h .6d0, .1d0, -.5d0, 0.d0,0.d0,0.d0,0.d0,
511 i 0.d0, .1d0, -3.0d0, 0.d0,0.d0,0.d0,0.d0,
512 j -.3d0, .1d0, -2.0d0, 0.d0,0.d0,0.d0,0.d0,
513 k 3.3d0, .1d0, -2.0d0, 0.d0,0.d0,0.d0,0.d0,
514 l .6d0, .1d0, -.5d0, .8d0, .9d0, -.3d0, -.4d0,
515 m -2.0d0, .1d0, 1.4d0, .8d0, .6d0, -.3d0, -2.8d0,
516 n -1.8d0, .1d0, 1.3d0, .8d0, 0.d0, -.3d0, -1.9d0,
517 o 3.8d0, .1d0, -3.1d0, .8d0, 4.8d0, -.3d0, -1.5d0 /
518*
519 DATA dt19xc/.6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
520 a .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
521 b .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
522 c .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
523 d .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
524 e -.8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
525 f -.9d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
526 g 3.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
527 h .6d0, .1d0, -.5d0, 0.d0,0.d0,0.d0,0.d0,
528 i 4.8d0, .1d0, -3.0d0, 0.d0,0.d0,0.d0,0.d0,
529 j 3.3d0, .1d0, -2.0d0, 0.d0,0.d0,0.d0,0.d0,
530 k 2.1d0, .1d0, -2.0d0, 0.d0,0.d0,0.d0,0.d0,
531 l .6d0, .1d0, -.5d0, .8d0, .9d0, -.3d0, -.4d0,
532 m -1.6d0, .1d0, -2.2d0, .8d0, 5.4d0, -.3d0, -2.8d0,
533 n -1.5d0, .1d0, -1.4d0, .8d0, 3.6d0, -.3d0, -1.9d0,
534 o 3.7d0, .1d0, -2.2d0, .8d0, 3.6d0, -.3d0, -1.5d0 /
535*
536 DATA dt19xd/.6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
537 a .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
538 b .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
539 c .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
540 d .6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
541 e -.8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
542 f -.9d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
543 g 3.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
544 h .6d0, .1d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
545 i -.8d0, -1.0d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
546 j -.9d0, -.8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
547 k 3.5d0, .8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
548 l .6d0, .1d0, -.5d0, .8d0, 0.d0,0.d0,0.d0,
549 m -.8d0, -1.0d0, 1.4d0, -1.6d0, 0.d0,0.d0,0.d0,
550 n -.9d0, -.8d0, 1.3d0, -1.6d0, 0.d0,0.d0,0.d0,
551 o 3.5d0, .8d0, -3.1d0, 4.8d0, 0.d0,0.d0,0.d0/
552* TRUE Y RESULTS FOR ROTATIONS DROTM
553 DATA dt19ya/.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
554 a .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
555 b .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
556 c .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
557 d .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
558 e .7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
559 f 1.7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
560 g -2.6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
561 h .5d0, -.9d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
562 i .7d0, -4.8d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
563 j 1.7d0, -.7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
564 k -2.6d0, 3.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
565 l .5d0, -.9d0, .3d0, .7d0, 0.d0,0.d0,0.d0,
566 m .7d0, -4.8d0, 3.0d0, 1.1d0, 0.d0,0.d0,0.d0,
567 n 1.7d0, -.7d0, -.7d0, 2.3d0, 0.d0,0.d0,0.d0,
568 o -2.6d0, 3.5d0, -.7d0, -3.6d0, 0.d0,0.d0,0.d0/
569*
570 DATA dt19yb/.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
571 a .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
572 b .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
573 c .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
574 d .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
575 e .7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
576 f 1.7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
577 g -2.6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
578 h .5d0, -.9d0, .3d0, 0.d0,0.d0,0.d0,0.d0,
579 i 4.0d0, -.9d0, -.3d0, 0.d0,0.d0,0.d0,0.d0,
580 j -.5d0, -.9d0, 1.5d0, 0.d0,0.d0,0.d0,0.d0,
581 k -1.5d0, -.9d0, -1.8d0, 0.d0,0.d0,0.d0,0.d0,
582 l .5d0, -.9d0, .3d0, .7d0, -.6d0, .2d0, .8d0,
583 m 3.7d0, -.9d0, -1.2d0, .7d0, -1.5d0, .2d0, 2.2d0,
584 n -.3d0, -.9d0, 2.1d0, .7d0, -1.6d0, .2d0, 2.0d0,
585 o -1.6d0, -.9d0, -2.1d0, .7d0, 2.9d0, .2d0, -3.8d0 /
586*
587 DATA dt19yc/.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
588 a .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
589 b .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
590 c .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
591 d .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
592 e .7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
593 f 1.7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
594 g -2.6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
595 h .5d0, -.9d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
596 i 4.0d0, -6.3d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
597 j -.5d0, .3d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
598 k -1.5d0, 3.0d0, 0.d0,0.d0,0.d0,0.d0,0.d0,
599 l .5d0, -.9d0, .3d0, .7d0, 0.d0,0.d0,0.d0,
600 m 3.7d0, -7.2d0, 3.0d0, 1.7d0, 0.d0,0.d0,0.d0,
601 n -.3d0, .9d0, -.7d0, 1.9d0, 0.d0,0.d0,0.d0,
602 o -1.6d0, 2.7d0, -.7d0, -3.4d0, 0.d0,0.d0,0.d0/
603*
604 DATA dt19yd/.5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
605 a .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
606 b .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
607 c .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
608 d .5d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
609 e .7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
610 f 1.7d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
611 g -2.6d0, 0.d0,0.d0,0.d0,0.d0,0.d0,0.d0,
612 h .5d0, -.9d0, .3d0, 0.d0,0.d0,0.d0,0.d0,
613 i .7d0, -.9d0, 1.2d0, 0.d0,0.d0,0.d0,0.d0,
614 j 1.7d0, -.9d0, .5d0, 0.d0,0.d0,0.d0,0.d0,
615 k -2.6d0, -.9d0, -1.3d0, 0.d0,0.d0,0.d0,0.d0,
616 l .5d0, -.9d0, .3d0, .7d0, -.6d0, .2d0, .8d0,
617 m .7d0, -.9d0, 1.2d0, .7d0, -1.5d0, .2d0, 1.6d0,
618 n 1.7d0, -.9d0, .5d0, .7d0, -1.6d0, .2d0, 2.4d0,
619 o -2.6d0, -.9d0, -1.3d0, .7d0, 2.9d0, .2d0, -4.0d0 /
620*
621* .. Executable Statements ..
622*
623 DO 120 ki = 1, 4
624 incx = incxs(ki)
625 incy = incys(ki)
626 mx = abs(incx)
627 my = abs(incy)
628*
629 DO 100 kn = 1, 4
630 n = ns(kn)
631 ksize = min(2,kn)
632 lenx = lens(kn,mx)
633 leny = lens(kn,my)
634* .. Initialize all argument arrays ..
635 DO 20 i = 1, 7
636 sx(i) = dx1(i)
637 sy(i) = dy1(i)
638 20 CONTINUE
639*
640 IF (icase.EQ.1) THEN
641* .. DDOT ..
642 CALL stest1(ddot(n,sx,incx,sy,incy),dt7(kn,ki),ssize1(kn)
643 + ,sfac)
644 ELSE IF (icase.EQ.2) THEN
645* .. DAXPY ..
646 CALL daxpy(n,sa,sx,incx,sy,incy)
647 DO 40 j = 1, leny
648 sty(j) = dt8(j,kn,ki)
649 40 CONTINUE
650 CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
651 ELSE IF (icase.EQ.5) THEN
652* .. DCOPY ..
653 DO 60 i = 1, 7
654 sty(i) = dt10y(i,kn,ki)
655 60 CONTINUE
656 CALL dcopy(n,sx,incx,sy,incy)
657 CALL stest(leny,sy,sty,ssize2(1,1),1.0d0)
658 IF (ki.EQ.1) THEN
659 sx0(1) = 42.0d0
660 sy0(1) = 43.0d0
661 IF (n.EQ.0) THEN
662 sty0(1) = sy0(1)
663 ELSE
664 sty0(1) = sx0(1)
665 END IF
666 lincx = incx
667 incx = 0
668 lincy = incy
669 incy = 0
670 CALL dcopy(n,sx0,incx,sy0,incy)
671 CALL stest(1,sy0,sty0,ssize2(1,1),1.0d0)
672 incx = lincx
673 incy = lincy
674 END IF
675 ELSE IF (icase.EQ.6) THEN
676* .. DSWAP ..
677 CALL dswap(n,sx,incx,sy,incy)
678 DO 80 i = 1, 7
679 stx(i) = dt10x(i,kn,ki)
680 sty(i) = dt10y(i,kn,ki)
681 80 CONTINUE
682 CALL stest(lenx,sx,stx,ssize2(1,1),1.0d0)
683 CALL stest(leny,sy,sty,ssize2(1,1),1.0d0)
684 ELSE IF (icase.EQ.12) THEN
685* .. DROTM ..
686 kni=kn+4*(ki-1)
687 DO kpar=1,4
688 DO i=1,7
689 sx(i) = dx1(i)
690 sy(i) = dy1(i)
691 stx(i)= dt19x(i,kpar,kni)
692 sty(i)= dt19y(i,kpar,kni)
693 END DO
694*
695 DO i=1,5
696 dtemp(i) = dpar(i,kpar)
697 END DO
698*
699 DO i=1,lenx
700 ssize(i)=stx(i)
701 END DO
702* SEE REMARK ABOVE ABOUT DT11X(1,2,7)
703* AND DT11X(5,3,8).
704 IF ((kpar .EQ. 2) .AND. (kni .EQ. 7))
705 $ ssize(1) = 2.4d0
706 IF ((kpar .EQ. 3) .AND. (kni .EQ. 8))
707 $ ssize(5) = 1.8d0
708*
709 CALL drotm(n,sx,incx,sy,incy,dtemp)
710 CALL stest(lenx,sx,stx,ssize,sfac)
711 CALL stest(leny,sy,sty,sty,sfac)
712 END DO
713 ELSE IF (icase.EQ.13) THEN
714* .. DSDOT ..
715 CALL testdsdot(real(dsdot(n,real(sx),incx,real(sy),incy)),
716 $ real(dt7(kn,ki)),real(ssize1(kn)), .3125e-1)
717 ELSE
718 WRITE (nout,*) ' Shouldn''t be here in CHECK2'
719 stop
720 END IF
721 100 CONTINUE
722 120 CONTINUE
723 RETURN
724*
725* End of CHECK2
726*
testdsdot
subroutine testdsdot(scomp, strue, ssize, sfac)
Definition dblat1.f:997
dsdot
double precision function dsdot(n, sx, incx, sy, incy)
DSDOT
Definition dsdot.f:119
ddot
double precision function ddot(n, dx, incx, dy, incy)
DDOT
Definition ddot.f:82
drotm
subroutine drotm(n, dx, incx, dy, incy, dparam)
DROTM
Definition drotm.f:96
dswap
subroutine dswap(n, dx, incx, dy, incy)
DSWAP
Definition dswap.f:82
daxpy
subroutine daxpy(n, da, dx, incx, dy, incy)
DAXPY
Definition daxpy.f:89
dcopy
subroutine dcopy(n, dx, incx, dy, incy)
DCOPY
Definition dcopy.f:82
min
#define min(a, b)
Definition macros.h:20

◆ check3()

subroutine check3 ( double precision sfac)

Definition at line 728 of file dblat1.f.

729* .. Parameters ..
730 INTEGER NOUT
731 parameter(nout=6)
732* .. Scalar Arguments ..
733 DOUBLE PRECISION SFAC
734* .. Scalars in Common ..
735 INTEGER ICASE, INCX, INCY, N
736 LOGICAL PASS
737* .. Local Scalars ..
738 DOUBLE PRECISION SC, SS
739 INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
740* .. Local Arrays ..
741 DOUBLE PRECISION COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
742 + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
743 + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
744 + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
745 + SY(7)
746 INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
747 + MWPINY(11), MWPN(11), NS(4)
748* .. External Subroutines ..
749 EXTERNAL drot, stest
750* .. Intrinsic Functions ..
751 INTRINSIC abs, min
752* .. Common blocks ..
753 COMMON /combla/icase, n, incx, incy, pass
754* .. Data statements ..
755 DATA incxs/1, 2, -2, -1/
756 DATA incys/1, -2, 1, -2/
757 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
758 DATA ns/0, 1, 2, 4/
759 DATA dx1/0.6d0, 0.1d0, -0.5d0, 0.8d0, 0.9d0, -0.3d0,
760 + -0.4d0/
761 DATA dy1/0.5d0, -0.9d0, 0.3d0, 0.7d0, -0.6d0, 0.2d0,
762 + 0.8d0/
763 DATA sc, ss/0.8d0, 0.6d0/
764 DATA dt9x/0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
765 + 0.0d0, 0.78d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
766 + 0.0d0, 0.0d0, 0.78d0, -0.46d0, 0.0d0, 0.0d0,
767 + 0.0d0, 0.0d0, 0.0d0, 0.78d0, -0.46d0, -0.22d0,
768 + 1.06d0, 0.0d0, 0.0d0, 0.0d0, 0.6d0, 0.0d0,
769 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.78d0,
770 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
771 + 0.66d0, 0.1d0, -0.1d0, 0.0d0, 0.0d0, 0.0d0,
772 + 0.0d0, 0.96d0, 0.1d0, -0.76d0, 0.8d0, 0.90d0,
773 + -0.3d0, -0.02d0, 0.6d0, 0.0d0, 0.0d0, 0.0d0,
774 + 0.0d0, 0.0d0, 0.0d0, 0.78d0, 0.0d0, 0.0d0,
775 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, -0.06d0, 0.1d0,
776 + -0.1d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.90d0,
777 + 0.1d0, -0.22d0, 0.8d0, 0.18d0, -0.3d0, -0.02d0,
778 + 0.6d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
779 + 0.78d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
780 + 0.0d0, 0.78d0, 0.26d0, 0.0d0, 0.0d0, 0.0d0,
781 + 0.0d0, 0.0d0, 0.78d0, 0.26d0, -0.76d0, 1.12d0,
782 + 0.0d0, 0.0d0, 0.0d0/
783 DATA dt9y/0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
784 + 0.0d0, 0.04d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
785 + 0.0d0, 0.0d0, 0.04d0, -0.78d0, 0.0d0, 0.0d0,
786 + 0.0d0, 0.0d0, 0.0d0, 0.04d0, -0.78d0, 0.54d0,
787 + 0.08d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0, 0.0d0,
788 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.04d0,
789 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.7d0,
790 + -0.9d0, -0.12d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
791 + 0.64d0, -0.9d0, -0.30d0, 0.7d0, -0.18d0, 0.2d0,
792 + 0.28d0, 0.5d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
793 + 0.0d0, 0.0d0, 0.04d0, 0.0d0, 0.0d0, 0.0d0,
794 + 0.0d0, 0.0d0, 0.0d0, 0.7d0, -1.08d0, 0.0d0,
795 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.64d0, -1.26d0,
796 + 0.54d0, 0.20d0, 0.0d0, 0.0d0, 0.0d0, 0.5d0,
797 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
798 + 0.04d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
799 + 0.0d0, 0.04d0, -0.9d0, 0.18d0, 0.0d0, 0.0d0,
800 + 0.0d0, 0.0d0, 0.04d0, -0.9d0, 0.18d0, 0.7d0,
801 + -0.18d0, 0.2d0, 0.16d0/
802 DATA ssize2/0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
803 + 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0, 0.0d0,
804 + 0.0d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
805 + 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0, 1.17d0,
806 + 1.17d0, 1.17d0, 1.17d0/
807* .. Executable Statements ..
808*
809 DO 60 ki = 1, 4
810 incx = incxs(ki)
811 incy = incys(ki)
812 mx = abs(incx)
813 my = abs(incy)
814*
815 DO 40 kn = 1, 4
816 n = ns(kn)
817 ksize = min(2,kn)
818 lenx = lens(kn,mx)
819 leny = lens(kn,my)
820*
821 IF (icase.EQ.4) THEN
822* .. DROT ..
823 DO 20 i = 1, 7
824 sx(i) = dx1(i)
825 sy(i) = dy1(i)
826 stx(i) = dt9x(i,kn,ki)
827 sty(i) = dt9y(i,kn,ki)
828 20 CONTINUE
829 CALL drot(n,sx,incx,sy,incy,sc,ss)
830 CALL stest(lenx,sx,stx,ssize2(1,ksize),sfac)
831 CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
832 ELSE
833 WRITE (nout,*) ' Shouldn''t be here in CHECK3'
834 stop
835 END IF
836 40 CONTINUE
837 60 CONTINUE
838*
839 mwpc(1) = 1
840 DO 80 i = 2, 11
841 mwpc(i) = 0
842 80 CONTINUE
843 mwps(1) = 0
844 DO 100 i = 2, 6
845 mwps(i) = 1
846 100 CONTINUE
847 DO 120 i = 7, 11
848 mwps(i) = -1
849 120 CONTINUE
850 mwpinx(1) = 1
851 mwpinx(2) = 1
852 mwpinx(3) = 1
853 mwpinx(4) = -1
854 mwpinx(5) = 1
855 mwpinx(6) = -1
856 mwpinx(7) = 1
857 mwpinx(8) = 1
858 mwpinx(9) = -1
859 mwpinx(10) = 1
860 mwpinx(11) = -1
861 mwpiny(1) = 1
862 mwpiny(2) = 1
863 mwpiny(3) = -1
864 mwpiny(4) = -1
865 mwpiny(5) = 2
866 mwpiny(6) = 1
867 mwpiny(7) = 1
868 mwpiny(8) = -1
869 mwpiny(9) = -1
870 mwpiny(10) = 2
871 mwpiny(11) = 1
872 DO 140 i = 1, 11
873 mwpn(i) = 5
874 140 CONTINUE
875 mwpn(5) = 3
876 mwpn(10) = 3
877 DO 160 i = 1, 5
878 mwpx(i) = i
879 mwpy(i) = i
880 mwptx(1,i) = i
881 mwpty(1,i) = i
882 mwptx(2,i) = i
883 mwpty(2,i) = -i
884 mwptx(3,i) = 6 - i
885 mwpty(3,i) = i - 6
886 mwptx(4,i) = i
887 mwpty(4,i) = -i
888 mwptx(6,i) = 6 - i
889 mwpty(6,i) = i - 6
890 mwptx(7,i) = -i
891 mwpty(7,i) = i
892 mwptx(8,i) = i - 6
893 mwpty(8,i) = 6 - i
894 mwptx(9,i) = -i
895 mwpty(9,i) = i
896 mwptx(11,i) = i - 6
897 mwpty(11,i) = 6 - i
898 160 CONTINUE
899 mwptx(5,1) = 1
900 mwptx(5,2) = 3
901 mwptx(5,3) = 5
902 mwptx(5,4) = 4
903 mwptx(5,5) = 5
904 mwpty(5,1) = -1
905 mwpty(5,2) = 2
906 mwpty(5,3) = -2
907 mwpty(5,4) = 4
908 mwpty(5,5) = -3
909 mwptx(10,1) = -1
910 mwptx(10,2) = -3
911 mwptx(10,3) = -5
912 mwptx(10,4) = 4
913 mwptx(10,5) = 5
914 mwpty(10,1) = 1
915 mwpty(10,2) = 2
916 mwpty(10,3) = 2
917 mwpty(10,4) = 4
918 mwpty(10,5) = 3
919 DO 200 i = 1, 11
920 incx = mwpinx(i)
921 incy = mwpiny(i)
922 DO 180 k = 1, 5
923 copyx(k) = mwpx(k)
924 copyy(k) = mwpy(k)
925 mwpstx(k) = mwptx(i,k)
926 mwpsty(k) = mwpty(i,k)
927 180 CONTINUE
928 CALL drot(mwpn(i),copyx,incx,copyy,incy,mwpc(i),mwps(i))
929 CALL stest(5,copyx,mwpstx,mwpstx,sfac)
930 CALL stest(5,copyy,mwpsty,mwpsty,sfac)
931 200 CONTINUE
932 RETURN
933*
934* End of CHECK3
935*
drot
subroutine drot(n, dx, incx, dy, incy, c, s)
DROT
Definition drot.f:92

◆ header()

subroutine header

Definition at line 95 of file dblat1.f.

96* .. Parameters ..
97 INTEGER NOUT
98 parameter(nout=6)
99* .. Scalars in Common ..
100 INTEGER ICASE, INCX, INCY, N
101 LOGICAL PASS
102* .. Local Arrays ..
103 CHARACTER*6 L(13)
104* .. Common blocks ..
105 COMMON /combla/icase, n, incx, incy, pass
106* .. Data statements ..
107 DATA l(1)/' DDOT '/
108 DATA l(2)/'DAXPY '/
109 DATA l(3)/'DROTG '/
110 DATA l(4)/' DROT '/
111 DATA l(5)/'DCOPY '/
112 DATA l(6)/'DSWAP '/
113 DATA l(7)/'DNRM2 '/
114 DATA l(8)/'DASUM '/
115 DATA l(9)/'DSCAL '/
116 DATA l(10)/'IDAMAX'/
117 DATA l(11)/'DROTMG'/
118 DATA l(12)/'DROTM '/
119 DATA l(13)/'DSDOT '/
120* .. Executable Statements ..
121 WRITE (nout,99999) icase, l(icase)
122 RETURN
123*
12499999 FORMAT (/' Test of subprogram number',i3,12x,a6)
125*
126* End of HEADER
127*

◆ itest1()

subroutine itest1 ( integer icomp,
integer itrue )

Definition at line 1088 of file dblat1.f.

1089* ********************************* ITEST1 *************************
1090*
1091* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
1092* EQUALITY.
1093* C. L. LAWSON, JPL, 1974 DEC 10
1094*
1095* .. Parameters ..
1096 INTEGER NOUT
1097 parameter(nout=6)
1098* .. Scalar Arguments ..
1099 INTEGER ICOMP, ITRUE
1100* .. Scalars in Common ..
1101 INTEGER ICASE, INCX, INCY, N
1102 LOGICAL PASS
1103* .. Local Scalars ..
1104 INTEGER ID
1105* .. Common blocks ..
1106 COMMON /combla/icase, n, incx, incy, pass
1107* .. Executable Statements ..
1108*
1109 IF (icomp.EQ.itrue) GO TO 40
1110*
1111* HERE ICOMP IS NOT EQUAL TO ITRUE.
1112*
1113 IF ( .NOT. pass) GO TO 20
1114* PRINT FAIL MESSAGE AND HEADER.
1115 pass = .false.
1116 WRITE (nout,99999)
1117 WRITE (nout,99998)
1118 20 id = icomp - itrue
1119 WRITE (nout,99997) icase, n, incx, incy, icomp, itrue, id
1120 40 CONTINUE
1121 RETURN
1122*
112399999 FORMAT (' FAIL')
112499998 FORMAT (/' CASE N INCX INCY ',
1125 + ' COMP TRUE DIFFERENCE',
1126 + /1x)
112799997 FORMAT (1x,i4,i3,2i5,2i36,i12)
1128*
1129* End of ITEST1
1130*
id
initmumps id
Definition multiplerhs_example.m:4

◆ sdiff()

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

Definition at line 1075 of file dblat1.f.

1076* ********************************* SDIFF **************************
1077* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
1078*
1079* .. Scalar Arguments ..
1080 DOUBLE PRECISION SA, SB
1081* .. Executable Statements ..
1082 sdiff = sa - sb
1083 RETURN
1084*
1085* End of SDIFF
1086*
sdiff
double precision function sdiff(sa, sb)
Definition dblat1.f:1076

◆ 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 937 of file dblat1.f.

938* ********************************* STEST **************************
939*
940* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
941* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
942* NEGLIGIBLE.
943*
944* C. L. LAWSON, JPL, 1974 DEC 10
945*
946* .. Parameters ..
947 INTEGER NOUT
948 DOUBLE PRECISION ZERO
949 parameter(nout=6, zero=0.0d0)
950* .. Scalar Arguments ..
951 DOUBLE PRECISION SFAC
952 INTEGER LEN
953* .. Array Arguments ..
954 DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
955* .. Scalars in Common ..
956 INTEGER ICASE, INCX, INCY, N
957 LOGICAL PASS
958* .. Local Scalars ..
959 DOUBLE PRECISION SD
960 INTEGER I
961* .. External Functions ..
962 DOUBLE PRECISION SDIFF
963 EXTERNAL sdiff
964* .. Intrinsic Functions ..
965 INTRINSIC abs
966* .. Common blocks ..
967 COMMON /combla/icase, n, incx, incy, pass
968* .. Executable Statements ..
969*
970 DO 40 i = 1, len
971 sd = scomp(i) - strue(i)
972 IF (abs(sfac*sd) .LE. abs(ssize(i))*epsilon(zero))
973 + GO TO 40
974*
975* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
976*
977 IF ( .NOT. pass) GO TO 20
978* PRINT FAIL MESSAGE AND HEADER.
979 pass = .false.
980 WRITE (nout,99999)
981 WRITE (nout,99998)
982 20 WRITE (nout,99997) icase, n, incx, incy, i, scomp(i),
983 + strue(i), sd, ssize(i)
984 40 CONTINUE
985 RETURN
986*
98799999 FORMAT (' FAIL')
98899998 FORMAT (/' CASE N INCX INCY I ',
989 + ' COMP(I) TRUE(I) DIFFERENCE',
990 + ' SIZE(I)',/1x)
99199997 FORMAT (1x,i4,i3,2i5,i3,2d36.8,2d12.4)
992*
993* End of STEST
994*

◆ stest1()

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

Definition at line 1047 of file dblat1.f.

1048* ************************* STEST1 *****************************
1049*
1050* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
1051* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
1052* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
1053*
1054* C.L. LAWSON, JPL, 1978 DEC 6
1055*
1056* .. Scalar Arguments ..
1057 DOUBLE PRECISION SCOMP1, SFAC, STRUE1
1058* .. Array Arguments ..
1059 DOUBLE PRECISION SSIZE(*)
1060* .. Local Arrays ..
1061 DOUBLE PRECISION SCOMP(1), STRUE(1)
1062* .. External Subroutines ..
1063 EXTERNAL stest
1064* .. Executable Statements ..
1065*
1066 scomp(1) = scomp1
1067 strue(1) = strue1
1068 CALL stest(1,scomp,strue,ssize,sfac)
1069*
1070 RETURN
1071*
1072* End of STEST1
1073*

◆ testdsdot()

subroutine testdsdot ( real scomp,
real strue,
real ssize,
real sfac )

Definition at line 996 of file dblat1.f.

997* ********************************* STEST **************************
998*
999* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
1000* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
1001* NEGLIGIBLE.
1002*
1003* C. L. LAWSON, JPL, 1974 DEC 10
1004*
1005* .. Parameters ..
1006 INTEGER NOUT
1007 REAL ZERO
1008 parameter(nout=6, zero=0.0e0)
1009* .. Scalar Arguments ..
1010 REAL SFAC, SCOMP, SSIZE, STRUE
1011* .. Scalars in Common ..
1012 INTEGER ICASE, INCX, INCY, N
1013 LOGICAL PASS
1014* .. Local Scalars ..
1015 REAL SD
1016* .. Intrinsic Functions ..
1017 INTRINSIC abs
1018* .. Common blocks ..
1019 COMMON /combla/icase, n, incx, incy, pass
1020* .. Executable Statements ..
1021*
1022 sd = scomp - strue
1023 IF (abs(sfac*sd) .LE. abs(ssize) * epsilon(zero))
1024 + GO TO 40
1025*
1026* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
1027*
1028 IF ( .NOT. pass) GO TO 20
1029* PRINT FAIL MESSAGE AND HEADER.
1030 pass = .false.
1031 WRITE (nout,99999)
1032 WRITE (nout,99998)
1033 20 WRITE (nout,99997) icase, n, incx, incy, scomp,
1034 + strue, sd, ssize
1035 40 CONTINUE
1036 RETURN
1037*
103899999 FORMAT (' FAIL')
103999998 FORMAT (/' CASE N INCX INCY ',
1040 + ' COMP(I) TRUE(I) DIFFERENCE',
1041 + ' SIZE(I)',/1x)
104299997 FORMAT (1x,i4,i3,1i5,i3,2e36.8,2e12.4)
1043*
1044* End of TESTDSDOT
1045*