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

Go to the source code of this file.

Functions/Subroutines

program scblat1
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 82 of file c_sblat1.f.

83* .. Parameters ..
84 INTEGER NOUT
85 parameter(nout=6)
86* .. Scalar Arguments ..
87 REAL SFAC
88* .. Scalars in Common ..
89 INTEGER ICASE, INCX, INCY, MODE, N
90 LOGICAL PASS
91* .. Local Scalars ..
92 REAL SA, SB, SC, SS
93 INTEGER K
94* .. Local Arrays ..
95 REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
96 + DS1(8)
97* .. External Subroutines ..
98 EXTERNAL srotgtest, stest1
99* .. Common blocks ..
100 COMMON /combla/icase, n, incx, incy, mode, pass
101* .. Data statements ..
102 DATA da1/0.3e0, 0.4e0, -0.3e0, -0.4e0, -0.3e0, 0.0e0,
103 + 0.0e0, 1.0e0/
104 DATA db1/0.4e0, 0.3e0, 0.4e0, 0.3e0, -0.4e0, 0.0e0,
105 + 1.0e0, 0.0e0/
106 DATA dc1/0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.6e0, 1.0e0,
107 + 0.0e0, 1.0e0/
108 DATA ds1/0.8e0, 0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.0e0,
109 + 1.0e0, 0.0e0/
110 DATA datrue/0.5e0, 0.5e0, 0.5e0, -0.5e0, -0.5e0,
111 + 0.0e0, 1.0e0, 1.0e0/
112 DATA dbtrue/0.0e0, 0.6e0, 0.0e0, -0.6e0, 0.0e0,
113 + 0.0e0, 1.0e0, 0.0e0/
114* .. Executable Statements ..
115*
116* Compute true values which cannot be prestored
117* in decimal notation
118*
119 dbtrue(1) = 1.0e0/0.6e0
120 dbtrue(3) = -1.0e0/0.6e0
121 dbtrue(5) = 1.0e0/0.6e0
122*
123 DO 20 k = 1, 8
124* .. Set N=K for identification in output if any ..
125 n = k
126 IF (icase.EQ.3) THEN
127* .. SROTGTEST ..
128 IF (k.GT.8) GO TO 40
129 sa = da1(k)
130 sb = db1(k)
131 CALL srotgtest(sa,sb,sc,ss)
132 CALL stest1(sa,datrue(k),datrue(k),sfac)
133 CALL stest1(sb,dbtrue(k),dbtrue(k),sfac)
134 CALL stest1(sc,dc1(k),dc1(k),sfac)
135 CALL stest1(ss,ds1(k),ds1(k),sfac)
136 ELSE
137 WRITE (nout,*) ' Shouldn''t be here in CHECK0'
138 stop
139 END IF
140 20 CONTINUE
141 40 RETURN
stest1
subroutine stest1(scomp1, strue1, ssize, sfac)
Definition c_sblat1.f:654

◆ check1()

subroutine check1 ( real sfac)

Definition at line 143 of file c_sblat1.f.

144* .. Parameters ..
145 INTEGER NOUT
146 parameter(nout=6)
147* .. Scalar Arguments ..
148 REAL SFAC
149* .. Scalars in Common ..
150 INTEGER ICASE, INCX, INCY, MODE, N
151 LOGICAL PASS
152* .. Local Scalars ..
153 INTEGER I, LEN, NP1
154* .. Local Arrays ..
155 REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
156 + SA(10), STEMP(1), STRUE(8), SX(8)
157 INTEGER ITRUE2(5)
158* .. External Functions ..
159 REAL SASUMTEST, SNRM2TEST
160 INTEGER ISAMAXTEST
161 EXTERNAL sasumtest, snrm2test, isamaxtest
162* .. External Subroutines ..
163 EXTERNAL itest1, sscaltest, stest, stest1
164* .. Intrinsic Functions ..
165 INTRINSIC max
166* .. Common blocks ..
167 COMMON /combla/icase, n, incx, incy, mode, pass
168* .. Data statements ..
169 DATA sa/0.3e0, -1.0e0, 0.0e0, 1.0e0, 0.3e0, 0.3e0,
170 + 0.3e0, 0.3e0, 0.3e0, 0.3e0/
171 DATA dv/0.1e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
172 + 2.0e0, 2.0e0, 0.3e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0,
173 + 3.0e0, 3.0e0, 3.0e0, 0.3e0, -0.4e0, 4.0e0,
174 + 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 0.2e0,
175 + -0.6e0, 0.3e0, 5.0e0, 5.0e0, 5.0e0, 5.0e0,
176 + 5.0e0, 0.1e0, -0.3e0, 0.5e0, -0.1e0, 6.0e0,
177 + 6.0e0, 6.0e0, 6.0e0, 0.1e0, 8.0e0, 8.0e0, 8.0e0,
178 + 8.0e0, 8.0e0, 8.0e0, 8.0e0, 0.3e0, 9.0e0, 9.0e0,
179 + 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 0.3e0, 2.0e0,
180 + -0.4e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
181 + 0.2e0, 3.0e0, -0.6e0, 5.0e0, 0.3e0, 2.0e0,
182 + 2.0e0, 2.0e0, 0.1e0, 4.0e0, -0.3e0, 6.0e0,
183 + -0.5e0, 7.0e0, -0.1e0, 3.0e0/
184 DATA dtrue1/0.0e0, 0.3e0, 0.5e0, 0.7e0, 0.6e0/
185 DATA dtrue3/0.0e0, 0.3e0, 0.7e0, 1.1e0, 1.0e0/
186 DATA dtrue5/0.10e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
187 + 2.0e0, 2.0e0, 2.0e0, -0.3e0, 3.0e0, 3.0e0,
188 + 3.0e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0, 0.0e0, 0.0e0,
189 + 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0,
190 + 0.20e0, -0.60e0, 0.30e0, 5.0e0, 5.0e0, 5.0e0,
191 + 5.0e0, 5.0e0, 0.03e0, -0.09e0, 0.15e0, -0.03e0,
192 + 6.0e0, 6.0e0, 6.0e0, 6.0e0, 0.10e0, 8.0e0,
193 + 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0,
194 + 0.09e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0,
195 + 9.0e0, 9.0e0, 0.09e0, 2.0e0, -0.12e0, 2.0e0,
196 + 2.0e0, 2.0e0, 2.0e0, 2.0e0, 0.06e0, 3.0e0,
197 + -0.18e0, 5.0e0, 0.09e0, 2.0e0, 2.0e0, 2.0e0,
198 + 0.03e0, 4.0e0, -0.09e0, 6.0e0, -0.15e0, 7.0e0,
199 + -0.03e0, 3.0e0/
200 DATA itrue2/0, 1, 2, 2, 3/
201* .. Executable Statements ..
202 DO 80 incx = 1, 2
203 DO 60 np1 = 1, 5
204 n = np1 - 1
205 len = 2*max(n,1)
206* .. Set vector arguments ..
207 DO 20 i = 1, len
208 sx(i) = dv(i,np1,incx)
209 20 CONTINUE
210*
211 IF (icase.EQ.7) THEN
212* .. SNRM2TEST ..
213 stemp(1) = dtrue1(np1)
214 CALL stest1(snrm2test(n,sx,incx),stemp(1),stemp,sfac)
215 ELSE IF (icase.EQ.8) THEN
216* .. SASUMTEST ..
217 stemp(1) = dtrue3(np1)
218 CALL stest1(sasumtest(n,sx,incx),stemp(1),stemp,sfac)
219 ELSE IF (icase.EQ.9) THEN
220* .. SSCALTEST ..
221 CALL sscaltest(n,sa((incx-1)*5+np1),sx,incx)
222 DO 40 i = 1, len
223 strue(i) = dtrue5(i,np1,incx)
224 40 CONTINUE
225 CALL stest(len,sx,strue,strue,sfac)
226 ELSE IF (icase.EQ.10) THEN
227* .. ISAMAXTEST ..
228 CALL itest1(isamaxtest(n,sx,incx),itrue2(np1))
229 ELSE
230 WRITE (nout,*) ' Shouldn''t be here in CHECK1'
231 stop
232 END IF
233 60 CONTINUE
234 80 CONTINUE
235 RETURN
stest
subroutine stest(len, scomp, strue, ssize, sfac)
Definition c_sblat1.f:599
itest1
subroutine itest1(icomp, itrue)
Definition c_sblat1.f:689
max
#define max(a, b)
Definition macros.h:21

◆ check2()

subroutine check2 ( real sfac)

Definition at line 237 of file c_sblat1.f.

238* .. Parameters ..
239 INTEGER NOUT
240 parameter(nout=6)
241* .. Scalar Arguments ..
242 REAL SFAC
243* .. Scalars in Common ..
244 INTEGER ICASE, INCX, INCY, MODE, N
245 LOGICAL PASS
246* .. Local Scalars ..
247 REAL SA
248 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
249* .. Local Arrays ..
250 REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
251 + DT8(7,4,4), DX1(7),
252 + DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7),
253 + SX(7), SY(7)
254 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
255* .. External Functions ..
256 REAL SDOTTEST
257 EXTERNAL sdottest
258* .. External Subroutines ..
259 EXTERNAL saxpytest, scopytest, sswaptest, stest, stest1
260* .. Intrinsic Functions ..
261 INTRINSIC abs, min
262* .. Common blocks ..
263 COMMON /combla/icase, n, incx, incy, mode, pass
264* .. Data statements ..
265 DATA sa/0.3e0/
266 DATA incxs/1, 2, -2, -1/
267 DATA incys/1, -2, 1, -2/
268 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
269 DATA ns/0, 1, 2, 4/
270 DATA dx1/0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.9e0, -0.3e0,
271 + -0.4e0/
272 DATA dy1/0.5e0, -0.9e0, 0.3e0, 0.7e0, -0.6e0, 0.2e0,
273 + 0.8e0/
274 DATA dt7/0.0e0, 0.30e0, 0.21e0, 0.62e0, 0.0e0,
275 + 0.30e0, -0.07e0, 0.85e0, 0.0e0, 0.30e0, -0.79e0,
276 + -0.74e0, 0.0e0, 0.30e0, 0.33e0, 1.27e0/
277 DATA dt8/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
278 + 0.0e0, 0.68e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
279 + 0.0e0, 0.0e0, 0.68e0, -0.87e0, 0.0e0, 0.0e0,
280 + 0.0e0, 0.0e0, 0.0e0, 0.68e0, -0.87e0, 0.15e0,
281 + 0.94e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
282 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.68e0,
283 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
284 + 0.35e0, -0.9e0, 0.48e0, 0.0e0, 0.0e0, 0.0e0,
285 + 0.0e0, 0.38e0, -0.9e0, 0.57e0, 0.7e0, -0.75e0,
286 + 0.2e0, 0.98e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0,
287 + 0.0e0, 0.0e0, 0.0e0, 0.68e0, 0.0e0, 0.0e0,
288 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.35e0, -0.72e0,
289 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.38e0,
290 + -0.63e0, 0.15e0, 0.88e0, 0.0e0, 0.0e0, 0.0e0,
291 + 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
292 + 0.68e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
293 + 0.0e0, 0.68e0, -0.9e0, 0.33e0, 0.0e0, 0.0e0,
294 + 0.0e0, 0.0e0, 0.68e0, -0.9e0, 0.33e0, 0.7e0,
295 + -0.75e0, 0.2e0, 1.04e0/
296 DATA dt10x/0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
297 + 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
298 + 0.0e0, 0.5e0, -0.9e0, 0.0e0, 0.0e0, 0.0e0,
299 + 0.0e0, 0.0e0, 0.5e0, -0.9e0, 0.3e0, 0.7e0,
300 + 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0,
301 + 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0,
302 + 0.0e0, 0.0e0, 0.0e0, 0.3e0, 0.1e0, 0.5e0, 0.0e0,
303 + 0.0e0, 0.0e0, 0.0e0, 0.8e0, 0.1e0, -0.6e0,
304 + 0.8e0, 0.3e0, -0.3e0, 0.5e0, 0.6e0, 0.0e0,
305 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
306 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.9e0,
307 + 0.1e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.7e0,
308 + 0.1e0, 0.3e0, 0.8e0, -0.9e0, -0.3e0, 0.5e0,
309 + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
310 + 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
311 + 0.5e0, 0.3e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
312 + 0.5e0, 0.3e0, -0.6e0, 0.8e0, 0.0e0, 0.0e0,
313 + 0.0e0/
314 DATA dt10y/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
315 + 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
316 + 0.0e0, 0.6e0, 0.1e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
317 + 0.0e0, 0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.0e0,
318 + 0.0e0, 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
319 + 0.0e0, 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
320 + 0.0e0, 0.0e0, -0.5e0, -0.9e0, 0.6e0, 0.0e0,
321 + 0.0e0, 0.0e0, 0.0e0, -0.4e0, -0.9e0, 0.9e0,
322 + 0.7e0, -0.5e0, 0.2e0, 0.6e0, 0.5e0, 0.0e0,
323 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0,
324 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.5e0,
325 + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
326 + -0.4e0, 0.9e0, -0.5e0, 0.6e0, 0.0e0, 0.0e0,
327 + 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
328 + 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
329 + 0.0e0, 0.6e0, -0.9e0, 0.1e0, 0.0e0, 0.0e0,
330 + 0.0e0, 0.0e0, 0.6e0, -0.9e0, 0.1e0, 0.7e0,
331 + -0.5e0, 0.2e0, 0.8e0/
332 DATA ssize1/0.0e0, 0.3e0, 1.6e0, 3.2e0/
333 DATA ssize2/0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
334 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
335 + 0.0e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
336 + 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
337 + 1.17e0, 1.17e0, 1.17e0/
338* .. Executable Statements ..
339*
340 DO 120 ki = 1, 4
341 incx = incxs(ki)
342 incy = incys(ki)
343 mx = abs(incx)
344 my = abs(incy)
345*
346 DO 100 kn = 1, 4
347 n = ns(kn)
348 ksize = min(2,kn)
349 lenx = lens(kn,mx)
350 leny = lens(kn,my)
351* .. Initialize all argument arrays ..
352 DO 20 i = 1, 7
353 sx(i) = dx1(i)
354 sy(i) = dy1(i)
355 20 CONTINUE
356*
357 IF (icase.EQ.1) THEN
358* .. SDOTTEST ..
359 CALL stest1(sdottest(n,sx,incx,sy,incy),dt7(kn,ki),
360 + ssize1(kn),sfac)
361 ELSE IF (icase.EQ.2) THEN
362* .. SAXPYTEST ..
363 CALL saxpytest(n,sa,sx,incx,sy,incy)
364 DO 40 j = 1, leny
365 sty(j) = dt8(j,kn,ki)
366 40 CONTINUE
367 CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
368 ELSE IF (icase.EQ.5) THEN
369* .. SCOPYTEST ..
370 DO 60 i = 1, 7
371 sty(i) = dt10y(i,kn,ki)
372 60 CONTINUE
373 CALL scopytest(n,sx,incx,sy,incy)
374 CALL stest(leny,sy,sty,ssize2(1,1),1.0e0)
375 ELSE IF (icase.EQ.6) THEN
376* .. SSWAPTEST ..
377 CALL sswaptest(n,sx,incx,sy,incy)
378 DO 80 i = 1, 7
379 stx(i) = dt10x(i,kn,ki)
380 sty(i) = dt10y(i,kn,ki)
381 80 CONTINUE
382 CALL stest(lenx,sx,stx,ssize2(1,1),1.0e0)
383 CALL stest(leny,sy,sty,ssize2(1,1),1.0e0)
384 ELSE
385 WRITE (nout,*) ' Shouldn''t be here in CHECK2'
386 stop
387 END IF
388 100 CONTINUE
389 120 CONTINUE
390 RETURN
min
#define min(a, b)
Definition macros.h:20

◆ check3()

subroutine check3 ( real sfac)

Definition at line 392 of file c_sblat1.f.

393* .. Parameters ..
394 INTEGER NOUT
395 parameter(nout=6)
396* .. Scalar Arguments ..
397 REAL SFAC
398* .. Scalars in Common ..
399 INTEGER ICASE, INCX, INCY, MODE, N
400 LOGICAL PASS
401* .. Local Scalars ..
402 REAL SC, SS
403 INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
404* .. Local Arrays ..
405 REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
406 + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
407 + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
408 + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
409 + SY(7)
410 INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
411 + MWPINY(11), MWPN(11), NS(4)
412* .. External Subroutines ..
413 EXTERNAL srottest, stest
414* .. Intrinsic Functions ..
415 INTRINSIC abs, min
416* .. Common blocks ..
417 COMMON /combla/icase, n, incx, incy, mode, pass
418* .. Data statements ..
419 DATA incxs/1, 2, -2, -1/
420 DATA incys/1, -2, 1, -2/
421 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
422 DATA ns/0, 1, 2, 4/
423 DATA dx1/0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.9e0, -0.3e0,
424 + -0.4e0/
425 DATA dy1/0.5e0, -0.9e0, 0.3e0, 0.7e0, -0.6e0, 0.2e0,
426 + 0.8e0/
427 DATA sc, ss/0.8e0, 0.6e0/
428 DATA dt9x/0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
429 + 0.0e0, 0.78e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
430 + 0.0e0, 0.0e0, 0.78e0, -0.46e0, 0.0e0, 0.0e0,
431 + 0.0e0, 0.0e0, 0.0e0, 0.78e0, -0.46e0, -0.22e0,
432 + 1.06e0, 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0,
433 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.78e0,
434 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
435 + 0.66e0, 0.1e0, -0.1e0, 0.0e0, 0.0e0, 0.0e0,
436 + 0.0e0, 0.96e0, 0.1e0, -0.76e0, 0.8e0, 0.90e0,
437 + -0.3e0, -0.02e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0,
438 + 0.0e0, 0.0e0, 0.0e0, 0.78e0, 0.0e0, 0.0e0,
439 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.06e0, 0.1e0,
440 + -0.1e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.90e0,
441 + 0.1e0, -0.22e0, 0.8e0, 0.18e0, -0.3e0, -0.02e0,
442 + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
443 + 0.78e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
444 + 0.0e0, 0.78e0, 0.26e0, 0.0e0, 0.0e0, 0.0e0,
445 + 0.0e0, 0.0e0, 0.78e0, 0.26e0, -0.76e0, 1.12e0,
446 + 0.0e0, 0.0e0, 0.0e0/
447 DATA dt9y/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
448 + 0.0e0, 0.04e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
449 + 0.0e0, 0.0e0, 0.04e0, -0.78e0, 0.0e0, 0.0e0,
450 + 0.0e0, 0.0e0, 0.0e0, 0.04e0, -0.78e0, 0.54e0,
451 + 0.08e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
452 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.04e0,
453 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.7e0,
454 + -0.9e0, -0.12e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
455 + 0.64e0, -0.9e0, -0.30e0, 0.7e0, -0.18e0, 0.2e0,
456 + 0.28e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
457 + 0.0e0, 0.0e0, 0.04e0, 0.0e0, 0.0e0, 0.0e0,
458 + 0.0e0, 0.0e0, 0.0e0, 0.7e0, -1.08e0, 0.0e0,
459 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.64e0, -1.26e0,
460 + 0.54e0, 0.20e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0,
461 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
462 + 0.04e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
463 + 0.0e0, 0.04e0, -0.9e0, 0.18e0, 0.0e0, 0.0e0,
464 + 0.0e0, 0.0e0, 0.04e0, -0.9e0, 0.18e0, 0.7e0,
465 + -0.18e0, 0.2e0, 0.16e0/
466 DATA ssize2/0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
467 + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
468 + 0.0e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
469 + 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
470 + 1.17e0, 1.17e0, 1.17e0/
471* .. Executable Statements ..
472*
473 DO 60 ki = 1, 4
474 incx = incxs(ki)
475 incy = incys(ki)
476 mx = abs(incx)
477 my = abs(incy)
478*
479 DO 40 kn = 1, 4
480 n = ns(kn)
481 ksize = min(2,kn)
482 lenx = lens(kn,mx)
483 leny = lens(kn,my)
484*
485 IF (icase.EQ.4) THEN
486* .. SROTTEST ..
487 DO 20 i = 1, 7
488 sx(i) = dx1(i)
489 sy(i) = dy1(i)
490 stx(i) = dt9x(i,kn,ki)
491 sty(i) = dt9y(i,kn,ki)
492 20 CONTINUE
493 CALL srottest(n,sx,incx,sy,incy,sc,ss)
494 CALL stest(lenx,sx,stx,ssize2(1,ksize),sfac)
495 CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
496 ELSE
497 WRITE (nout,*) ' Shouldn''t be here in CHECK3'
498 stop
499 END IF
500 40 CONTINUE
501 60 CONTINUE
502*
503 mwpc(1) = 1
504 DO 80 i = 2, 11
505 mwpc(i) = 0
506 80 CONTINUE
507 mwps(1) = 0
508 DO 100 i = 2, 6
509 mwps(i) = 1
510 100 CONTINUE
511 DO 120 i = 7, 11
512 mwps(i) = -1
513 120 CONTINUE
514 mwpinx(1) = 1
515 mwpinx(2) = 1
516 mwpinx(3) = 1
517 mwpinx(4) = -1
518 mwpinx(5) = 1
519 mwpinx(6) = -1
520 mwpinx(7) = 1
521 mwpinx(8) = 1
522 mwpinx(9) = -1
523 mwpinx(10) = 1
524 mwpinx(11) = -1
525 mwpiny(1) = 1
526 mwpiny(2) = 1
527 mwpiny(3) = -1
528 mwpiny(4) = -1
529 mwpiny(5) = 2
530 mwpiny(6) = 1
531 mwpiny(7) = 1
532 mwpiny(8) = -1
533 mwpiny(9) = -1
534 mwpiny(10) = 2
535 mwpiny(11) = 1
536 DO 140 i = 1, 11
537 mwpn(i) = 5
538 140 CONTINUE
539 mwpn(5) = 3
540 mwpn(10) = 3
541 DO 160 i = 1, 5
542 mwpx(i) = i
543 mwpy(i) = i
544 mwptx(1,i) = i
545 mwpty(1,i) = i
546 mwptx(2,i) = i
547 mwpty(2,i) = -i
548 mwptx(3,i) = 6 - i
549 mwpty(3,i) = i - 6
550 mwptx(4,i) = i
551 mwpty(4,i) = -i
552 mwptx(6,i) = 6 - i
553 mwpty(6,i) = i - 6
554 mwptx(7,i) = -i
555 mwpty(7,i) = i
556 mwptx(8,i) = i - 6
557 mwpty(8,i) = 6 - i
558 mwptx(9,i) = -i
559 mwpty(9,i) = i
560 mwptx(11,i) = i - 6
561 mwpty(11,i) = 6 - i
562 160 CONTINUE
563 mwptx(5,1) = 1
564 mwptx(5,2) = 3
565 mwptx(5,3) = 5
566 mwptx(5,4) = 4
567 mwptx(5,5) = 5
568 mwpty(5,1) = -1
569 mwpty(5,2) = 2
570 mwpty(5,3) = -2
571 mwpty(5,4) = 4
572 mwpty(5,5) = -3
573 mwptx(10,1) = -1
574 mwptx(10,2) = -3
575 mwptx(10,3) = -5
576 mwptx(10,4) = 4
577 mwptx(10,5) = 5
578 mwpty(10,1) = 1
579 mwpty(10,2) = 2
580 mwpty(10,3) = 2
581 mwpty(10,4) = 4
582 mwpty(10,5) = 3
583 DO 200 i = 1, 11
584 incx = mwpinx(i)
585 incy = mwpiny(i)
586 DO 180 k = 1, 5
587 copyx(k) = mwpx(k)
588 copyy(k) = mwpy(k)
589 mwpstx(k) = mwptx(i,k)
590 mwpsty(k) = mwpty(i,k)
591 180 CONTINUE
592 CALL srottest(mwpn(i),copyx,incx,copyy,incy,mwpc(i),mwps(i))
593 CALL stest(5,copyx,mwpstx,mwpstx,sfac)
594 CALL stest(5,copyy,mwpsty,mwpsty,sfac)
595 200 CONTINUE
596 RETURN

◆ header()

subroutine header

Definition at line 54 of file c_sblat1.f.

55* .. Parameters ..
56 INTEGER NOUT
57 parameter(nout=6)
58* .. Scalars in Common ..
59 INTEGER ICASE, INCX, INCY, MODE, N
60 LOGICAL PASS
61* .. Local Arrays ..
62 CHARACTER*15 L(10)
63* .. Common blocks ..
64 COMMON /combla/icase, n, incx, incy, mode, pass
65* .. Data statements ..
66 DATA l(1)/'CBLAS_SDOT '/
67 DATA l(2)/'CBLAS_SAXPY '/
68 DATA l(3)/'CBLAS_SROTG '/
69 DATA l(4)/'CBLAS_SROT '/
70 DATA l(5)/'CBLAS_SCOPY '/
71 DATA l(6)/'CBLAS_SSWAP '/
72 DATA l(7)/'CBLAS_SNRM2 '/
73 DATA l(8)/'CBLAS_SASUM '/
74 DATA l(9)/'CBLAS_SSCAL '/
75 DATA l(10)/'CBLAS_ISAMAX'/
76* .. Executable Statements ..
77 WRITE (nout,99999) icase, l(icase)
78 RETURN
79*
8099999 FORMAT (/' Test of subprogram number',i3,9x,a15)

◆ itest1()

subroutine itest1 ( integer icomp,
integer itrue )

Definition at line 688 of file c_sblat1.f.

689* ********************************* ITEST1 *************************
690*
691* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
692* EQUALITY.
693* C. L. LAWSON, JPL, 1974 DEC 10
694*
695* .. Parameters ..
696 INTEGER NOUT
697 parameter(nout=6)
698* .. Scalar Arguments ..
699 INTEGER ICOMP, ITRUE
700* .. Scalars in Common ..
701 INTEGER ICASE, INCX, INCY, MODE, N
702 LOGICAL PASS
703* .. Local Scalars ..
704 INTEGER ID
705* .. Common blocks ..
706 COMMON /combla/icase, n, incx, incy, mode, pass
707* .. Executable Statements ..
708*
709 IF (icomp.EQ.itrue) GO TO 40
710*
711* HERE ICOMP IS NOT EQUAL TO ITRUE.
712*
713 IF ( .NOT. pass) GO TO 20
714* PRINT FAIL MESSAGE AND HEADER.
715 pass = .false.
716 WRITE (nout,99999)
717 WRITE (nout,99998)
718 20 id = icomp - itrue
719 WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
720 40 CONTINUE
721 RETURN
722*
72399999 FORMAT (' FAIL')
72499998 FORMAT (/' CASE N INCX INCY MODE ',
725 + ' COMP TRUE DIFFERENCE',
726 + /1x)
72799997 FORMAT (1x,i4,i3,3i5,2i36,i12)
id
initmumps id
Definition multiplerhs_example.m:4

◆ scblat1()

program scblat1

Definition at line 1 of file c_sblat1.f.

◆ sdiff()

real function sdiff ( real sa,
real sb )

Definition at line 678 of file c_sblat1.f.

679* ********************************* SDIFF **************************
680* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
681*
682* .. Scalar Arguments ..
683 REAL SA, SB
684* .. Executable Statements ..
685 sdiff = sa - sb
686 RETURN
sdiff
real function sdiff(sa, sb)
Definition c_sblat1.f:679

◆ stest()

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

Definition at line 598 of file c_sblat1.f.

599* ********************************* STEST **************************
600*
601* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
602* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
603* NEGLIGIBLE.
604*
605* C. L. LAWSON, JPL, 1974 DEC 10
606*
607* .. Parameters ..
608 INTEGER NOUT
609 parameter(nout=6)
610* .. Scalar Arguments ..
611 REAL SFAC
612 INTEGER LEN
613* .. Array Arguments ..
614 REAL SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
615* .. Scalars in Common ..
616 INTEGER ICASE, INCX, INCY, MODE, N
617 LOGICAL PASS
618* .. Local Scalars ..
619 REAL SD
620 INTEGER I
621* .. External Functions ..
622 REAL SDIFF
623 EXTERNAL sdiff
624* .. Intrinsic Functions ..
625 INTRINSIC abs
626* .. Common blocks ..
627 COMMON /combla/icase, n, incx, incy, mode, pass
628* .. Executable Statements ..
629*
630 DO 40 i = 1, len
631 sd = scomp(i) - strue(i)
632 IF (sdiff(abs(ssize(i))+abs(sfac*sd),abs(ssize(i))).EQ.0.0e0)
633 + GO TO 40
634*
635* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
636*
637 IF ( .NOT. pass) GO TO 20
638* PRINT FAIL MESSAGE AND HEADER.
639 pass = .false.
640 WRITE (nout,99999)
641 WRITE (nout,99998)
642 20 WRITE (nout,99997) icase, n, incx, incy, mode, i, scomp(i),
643 + strue(i), sd, ssize(i)
644 40 CONTINUE
645 RETURN
646*
64799999 FORMAT (' FAIL')
64899998 FORMAT (/' CASE N INCX INCY MODE I ',
649 + ' COMP(I) TRUE(I) DIFFERENCE',
650 + ' SIZE(I)',/1x)
65199997 FORMAT (1x,i4,i3,3i5,i3,2e36.8,2e12.4)

◆ stest1()

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

Definition at line 653 of file c_sblat1.f.

654* ************************* STEST1 *****************************
655*
656* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
657* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
658* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
659*
660* C.L. LAWSON, JPL, 1978 DEC 6
661*
662* .. Scalar Arguments ..
663 REAL SCOMP1, SFAC, STRUE1
664* .. Array Arguments ..
665 REAL SSIZE(*)
666* .. Local Arrays ..
667 REAL SCOMP(1), STRUE(1)
668* .. External Subroutines ..
669 EXTERNAL stest
670* .. Executable Statements ..
671*
672 scomp(1) = scomp1
673 strue(1) = strue1
674 CALL stest(1,scomp,strue,ssize,sfac)
675*
676 RETURN