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

Go to the source code of this file.

Functions/Subroutines

program sblat1
 SBLAT1
subroutine header
subroutine check0 (sfac)
subroutine check1 (sfac)
subroutine check2 (sfac)
subroutine check3 (sfac)
subroutine stest (len, scomp, strue, ssize, sfac)
subroutine stest1 (scomp1, strue1, ssize, sfac)
real function sdiff (sa, sb)
subroutine itest1 (icomp, itrue)

Function/Subroutine Documentation

◆ check0()

subroutine check0 ( real sfac)

Definition at line 129 of file sblat1.f.

130* .. Parameters ..
131 INTEGER NOUT
132 parameter(nout=6)
133* .. Scalar Arguments ..
134 REAL SFAC
135* .. Scalars in Common ..
136 INTEGER ICASE, INCX, INCY, N
137 LOGICAL PASS
138* .. Local Scalars ..
139 REAL D12, SA, SB, SC, SS
140 INTEGER I, K
141* .. Local Arrays ..
142 REAL 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 srotg, srotmg, stest, stest1
146* .. Common blocks ..
147 COMMON /combla/icase, n, incx, incy, pass
148* .. Data statements ..
149 DATA da1/0.3e0, 0.4e0, -0.3e0, -0.4e0, -0.3e0, 0.0e0,
150 + 0.0e0, 1.0e0/
151 DATA db1/0.4e0, 0.3e0, 0.4e0, 0.3e0, -0.4e0, 0.0e0,
152 + 1.0e0, 0.0e0/
153 DATA dc1/0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.6e0, 1.0e0,
154 + 0.0e0, 1.0e0/
155 DATA ds1/0.8e0, 0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.0e0,
156 + 1.0e0, 0.0e0/
157 DATA datrue/0.5e0, 0.5e0, 0.5e0, -0.5e0, -0.5e0,
158 + 0.0e0, 1.0e0, 1.0e0/
159 DATA dbtrue/0.0e0, 0.6e0, 0.0e0, -0.6e0, 0.0e0,
160 + 0.0e0, 1.0e0, 0.0e0/
161* INPUT FOR MODIFIED GIVENS
162 DATA dab/ .1e0,.3e0,1.2e0,.2e0,
163 a .7e0, .2e0, .6e0, 4.2e0,
164 b 0.e0,0.e0,0.e0,0.e0,
165 c 4.e0, -1.e0, 2.e0, 4.e0,
166 d 6.e-10, 2.e-2, 1.e5, 10.e0,
167 e 4.e10, 2.e-2, 1.e-5, 10.e0,
168 f 2.e-10, 4.e-2, 1.e5, 10.e0,
169 g 2.e10, 4.e-2, 1.e-5, 10.e0,
170 h 4.e0, -2.e0, 8.e0, 4.e0 /
171* TRUE RESULTS FOR MODIFIED GIVENS
172 DATA dtrue/0.e0,0.e0, 1.3e0, .2e0, 0.e0,0.e0,0.e0, .5e0, 0.e0,
173 a 0.e0,0.e0, 4.5e0, 4.2e0, 1.e0, .5e0, 0.e0,0.e0,0.e0,
174 b 0.e0,0.e0,0.e0,0.e0, -2.e0, 0.e0,0.e0,0.e0,0.e0,
175 c 0.e0,0.e0,0.e0, 4.e0, -1.e0, 0.e0,0.e0,0.e0,0.e0,
176 d 0.e0, 15.e-3, 0.e0, 10.e0, -1.e0, 0.e0, -1.e-4,
177 e 0.e0, 1.e0,
178 f 0.e0,0.e0, 6144.e-5, 10.e0, -1.e0, 4096.e0, -1.e6,
179 g 0.e0, 1.e0,
180 h 0.e0,0.e0,15.e0,10.e0,-1.e0, 5.e-5, 0.e0,1.e0,0.e0,
181 i 0.e0,0.e0, 15.e0, 10.e0, -1. e0, 5.e5, -4096.e0,
182 j 1.e0, 4096.e-6,
183 k 0.e0,0.e0, 7.e0, 4.e0, 0.e0,0.e0, -.5e0, -.25e0, 0.e0/
184* 4096 = 2 ** 12
185 DATA d12 /4096.e0/
186 dtrue(1,1) = 12.e0 / 130.e0
187 dtrue(2,1) = 36.e0 / 130.e0
188 dtrue(7,1) = -1.e0 / 6.e0
189 dtrue(1,2) = 14.e0 / 75.e0
190 dtrue(2,2) = 49.e0 / 75.e0
191 dtrue(9,2) = 1.e0 / 7.e0
192 dtrue(1,5) = 45.e-11 * (d12 * d12)
193 dtrue(3,5) = 4.e5 / (3.e0 * d12)
194 dtrue(6,5) = 1.e0 / d12
195 dtrue(8,5) = 1.e4 / (3.e0 * d12)
196 dtrue(1,6) = 4.e10 / (1.5e0 * d12 * d12)
197 dtrue(2,6) = 2.e-2 / 1.5e0
198 dtrue(8,6) = 5.e-7 * d12
199 dtrue(1,7) = 4.e0 / 150.e0
200 dtrue(2,7) = (2.e-10 / 1.5e0) * (d12 * d12)
201 dtrue(7,7) = -dtrue(6,5)
202 dtrue(9,7) = 1.e4 / d12
203 dtrue(1,8) = dtrue(1,7)
204 dtrue(2,8) = 2.e10 / (1.5e0 * d12 * d12)
205 dtrue(1,9) = 32.e0 / 7.e0
206 dtrue(2,9) = -16.e0 / 7.e0
207* .. Executable Statements ..
208*
209* Compute true values which cannot be prestored
210* in decimal notation
211*
212 dbtrue(1) = 1.0e0/0.6e0
213 dbtrue(3) = -1.0e0/0.6e0
214 dbtrue(5) = 1.0e0/0.6e0
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* .. SROTG ..
221 IF (k.GT.8) GO TO 40
222 sa = da1(k)
223 sb = db1(k)
224 CALL srotg(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* .. SROTMG ..
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 srotmg(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*
srotmg
subroutine srotmg(sd1, sd2, sx1, sy1, sparam)
SROTMG
Definition srotmg.f:90
srotg
subroutine srotg(a, b, c, s)
SROTG
Definition srotg.f90:93
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition sblat1.f:940
stest1
subroutine stest1(scomp1, strue1, ssize, sfac)
Definition sblat1.f:999

◆ check1()

subroutine check1 ( real sfac)

Definition at line 248 of file sblat1.f.

249* .. Parameters ..
250 INTEGER NOUT
251 parameter(nout=6)
252* .. Scalar Arguments ..
253 REAL 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 REAL 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 REAL SASUM, SNRM2
266 INTEGER ISAMAX
267 EXTERNAL sasum, snrm2, isamax
268* .. External Subroutines ..
269 EXTERNAL itest1, sscal, 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.3e0, -1.0e0, 0.0e0, 1.0e0, 0.3e0, 0.3e0,
276 + 0.3e0, 0.3e0, 0.3e0, 0.3e0/
277 DATA dv/0.1e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
278 + 2.0e0, 2.0e0, 0.3e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0,
279 + 3.0e0, 3.0e0, 3.0e0, 0.3e0, -0.4e0, 4.0e0,
280 + 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 0.2e0,
281 + -0.6e0, 0.3e0, 5.0e0, 5.0e0, 5.0e0, 5.0e0,
282 + 5.0e0, 0.1e0, -0.3e0, 0.5e0, -0.1e0, 6.0e0,
283 + 6.0e0, 6.0e0, 6.0e0, 0.1e0, 8.0e0, 8.0e0, 8.0e0,
284 + 8.0e0, 8.0e0, 8.0e0, 8.0e0, 0.3e0, 9.0e0, 9.0e0,
285 + 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 0.3e0, 2.0e0,
286 + -0.4e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
287 + 0.2e0, 3.0e0, -0.6e0, 5.0e0, 0.3e0, 2.0e0,
288 + 2.0e0, 2.0e0, 0.1e0, 4.0e0, -0.3e0, 6.0e0,
289 + -0.5e0, 7.0e0, -0.1e0, 3.0e0/
290 DATA dvr/8.0e0, -7.0e0, 9.0e0, 5.0e0, 9.0e0, 8.0e0,
291 + 7.0e0, 7.0e0/
292 DATA dtrue1/0.0e0, 0.3e0, 0.5e0, 0.7e0, 0.6e0/
293 DATA dtrue3/0.0e0, 0.3e0, 0.7e0, 1.1e0, 1.0e0/
294 DATA dtrue5/0.10e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
295 + 2.0e0, 2.0e0, 2.0e0, -0.3e0, 3.0e0, 3.0e0,
296 + 3.0e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0, 0.0e0, 0.0e0,
297 + 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0,
298 + 0.20e0, -0.60e0, 0.30e0, 5.0e0, 5.0e0, 5.0e0,
299 + 5.0e0, 5.0e0, 0.03e0, -0.09e0, 0.15e0, -0.03e0,
300 + 6.0e0, 6.0e0, 6.0e0, 6.0e0, 0.10e0, 8.0e0,
301 + 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0,
302 + 0.09e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0,
303 + 9.0e0, 9.0e0, 0.09e0, 2.0e0, -0.12e0, 2.0e0,
304 + 2.0e0, 2.0e0, 2.0e0, 2.0e0, 0.06e0, 3.0e0,
305 + -0.18e0, 5.0e0, 0.09e0, 2.0e0, 2.0e0, 2.0e0,
306 + 0.03e0, 4.0e0, -0.09e0, 6.0e0, -0.15e0, 7.0e0,
307 + -0.03e0, 3.0e0/
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* .. SNRM2 ..
322 stemp(1) = dtrue1(np1)
323 CALL stest1(snrm2(n,sx,incx),stemp(1),stemp,sfac)
324 ELSE IF (icase.EQ.8) THEN
325* .. SASUM ..
326 stemp(1) = dtrue3(np1)
327 CALL stest1(sasum(n,sx,incx),stemp(1),stemp,sfac)
328 ELSE IF (icase.EQ.9) THEN
329* .. SSCAL ..
330 CALL sscal(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* .. ISAMAX ..
337 CALL itest1(isamax(n,sx,incx),itrue2(np1))
338 DO 100 i = 1, len
339 sx(i) = 42.0e0
340 100 CONTINUE
341 CALL itest1(isamax(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(isamax(n,sxr,incx),3)
355 END IF
356 80 CONTINUE
357 RETURN
358*
359* End of CHECK1
360*
isamax
integer function isamax(n, sx, incx)
ISAMAX
Definition isamax.f:71
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
sasum
real function sasum(n, sx, incx)
SASUM
Definition sasum.f:72
snrm2
real(wp) function snrm2(n, x, incx)
SNRM2
Definition snrm2.f90:89
max
#define max(a, b)
Definition macros.h:21
itest1
subroutine itest1(icomp, itrue)
Definition sblat1.f:1040

◆ check2()

subroutine check2 ( real sfac)

Definition at line 362 of file sblat1.f.

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

◆ check3()

subroutine check3 ( real sfac)

Definition at line 730 of file sblat1.f.

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

◆ header()

subroutine header

Definition at line 95 of file sblat1.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)/' SDOT '/
108 DATA l(2)/'SAXPY '/
109 DATA l(3)/'SROTG '/
110 DATA l(4)/' SROT '/
111 DATA l(5)/'SCOPY '/
112 DATA l(6)/'SSWAP '/
113 DATA l(7)/'SNRM2 '/
114 DATA l(8)/'SASUM '/
115 DATA l(9)/'SSCAL '/
116 DATA l(10)/'ISAMAX'/
117 DATA l(11)/'SROTMG'/
118 DATA l(12)/'SROTM '/
119 DATA l(13)/'SDSDOT'/
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 1039 of file sblat1.f.

1040* ********************************* ITEST1 *************************
1041*
1042* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
1043* EQUALITY.
1044* C. L. LAWSON, JPL, 1974 DEC 10
1045*
1046* .. Parameters ..
1047 INTEGER NOUT
1048 parameter(nout=6)
1049* .. Scalar Arguments ..
1050 INTEGER ICOMP, ITRUE
1051* .. Scalars in Common ..
1052 INTEGER ICASE, INCX, INCY, N
1053 LOGICAL PASS
1054* .. Local Scalars ..
1055 INTEGER ID
1056* .. Common blocks ..
1057 COMMON /combla/icase, n, incx, incy, pass
1058* .. Executable Statements ..
1059*
1060 IF (icomp.EQ.itrue) GO TO 40
1061*
1062* HERE ICOMP IS NOT EQUAL TO ITRUE.
1063*
1064 IF ( .NOT. pass) GO TO 20
1065* PRINT FAIL MESSAGE AND HEADER.
1066 pass = .false.
1067 WRITE (nout,99999)
1068 WRITE (nout,99998)
1069 20 id = icomp - itrue
1070 WRITE (nout,99997) icase, n, incx, incy, icomp, itrue, id
1071 40 CONTINUE
1072 RETURN
1073*
107499999 FORMAT (' FAIL')
107599998 FORMAT (/' CASE N INCX INCY ',
1076 + ' COMP TRUE DIFFERENCE',
1077 + /1x)
107899997 FORMAT (1x,i4,i3,2i5,2i36,i12)
1079*
1080* End of ITEST1
1081*
id
initmumps id
Definition multiplerhs_example.m:4

◆ sdiff()

real function sdiff ( real sa,
real sb )

Definition at line 1026 of file sblat1.f.

1027* ********************************* SDIFF **************************
1028* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
1029*
1030* .. Scalar Arguments ..
1031 REAL SA, SB
1032* .. Executable Statements ..
1033 sdiff = sa - sb
1034 RETURN
1035*
1036* End of SDIFF
1037*
sdiff
real function sdiff(sa, sb)
Definition sblat1.f:1027

◆ stest()

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

Definition at line 939 of file sblat1.f.

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

◆ stest1()

subroutine stest1 ( real scomp1,
real strue1,
real, dimension(*) ssize,
real sfac )

Definition at line 998 of file sblat1.f.

999* ************************* STEST1 *****************************
1000*
1001* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
1002* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
1003* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
1004*
1005* C.L. LAWSON, JPL, 1978 DEC 6
1006*
1007* .. Scalar Arguments ..
1008 REAL SCOMP1, SFAC, STRUE1
1009* .. Array Arguments ..
1010 REAL SSIZE(*)
1011* .. Local Arrays ..
1012 REAL SCOMP(1), STRUE(1)
1013* .. External Subroutines ..
1014 EXTERNAL stest
1015* .. Executable Statements ..
1016*
1017 scomp(1) = scomp1
1018 strue(1) = strue1
1019 CALL stest(1,scomp,strue,ssize,sfac)
1020*
1021 RETURN
1022*
1023* End of STEST1
1024*