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

Go to the source code of this file.

Functions/Subroutines

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

Function/Subroutine Documentation

◆ check1()

subroutine check1 ( real sfac)

Definition at line 121 of file cblat1.f.

122* .. Parameters ..
123 INTEGER NOUT
124 parameter(nout=6)
125* .. Scalar Arguments ..
126 REAL SFAC
127* .. Scalars in Common ..
128 INTEGER ICASE, INCX, INCY, MODE, N
129 LOGICAL PASS
130* .. Local Scalars ..
131 COMPLEX CA
132 REAL SA
133 INTEGER I, IX, J, LEN, NP1
134* .. Local Arrays ..
135 COMPLEX CTRUE5(8,5,2), CTRUE6(8,5,2), CV(8,5,2), CVR(8),
136 + CX(8), CXR(15), MWPCS(5), MWPCT(5)
137 REAL STRUE2(5), STRUE4(5)
138 INTEGER ITRUE3(5), ITRUEC(5)
139* .. External Functions ..
140 REAL SCASUM, SCNRM2
141 INTEGER ICAMAX
142 EXTERNAL scasum, scnrm2, icamax
143* .. External Subroutines ..
144 EXTERNAL cscal, csscal, ctest, itest1, stest1
145* .. Intrinsic Functions ..
146 INTRINSIC max
147* .. Common blocks ..
148 COMMON /combla/icase, n, incx, incy, mode, pass
149* .. Data statements ..
150 DATA sa, ca/0.3e0, (0.4e0,-0.7e0)/
151 DATA ((cv(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
152 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
153 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
154 + (1.0e0,2.0e0), (0.3e0,-0.4e0), (3.0e0,4.0e0),
155 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
156 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
157 + (0.1e0,-0.3e0), (0.5e0,-0.1e0), (5.0e0,6.0e0),
158 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
159 + (5.0e0,6.0e0), (5.0e0,6.0e0), (0.1e0,0.1e0),
160 + (-0.6e0,0.1e0), (0.1e0,-0.3e0), (7.0e0,8.0e0),
161 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
162 + (7.0e0,8.0e0), (0.3e0,0.1e0), (0.5e0,0.0e0),
163 + (0.0e0,0.5e0), (0.0e0,0.2e0), (2.0e0,3.0e0),
164 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
165 DATA ((cv(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
166 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
167 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
168 + (4.0e0,5.0e0), (0.3e0,-0.4e0), (6.0e0,7.0e0),
169 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
170 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
171 + (0.1e0,-0.3e0), (8.0e0,9.0e0), (0.5e0,-0.1e0),
172 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
173 + (2.0e0,5.0e0), (2.0e0,5.0e0), (0.1e0,0.1e0),
174 + (3.0e0,6.0e0), (-0.6e0,0.1e0), (4.0e0,7.0e0),
175 + (0.1e0,-0.3e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
176 + (7.0e0,2.0e0), (0.3e0,0.1e0), (5.0e0,8.0e0),
177 + (0.5e0,0.0e0), (6.0e0,9.0e0), (0.0e0,0.5e0),
178 + (8.0e0,3.0e0), (0.0e0,0.2e0), (9.0e0,4.0e0)/
179 DATA cvr/(8.0e0,8.0e0), (-7.0e0,-7.0e0),
180 + (9.0e0,9.0e0), (5.0e0,5.0e0), (9.0e0,9.0e0),
181 + (8.0e0,8.0e0), (7.0e0,7.0e0), (7.0e0,7.0e0)/
182 DATA strue2/0.0e0, 0.5e0, 0.6e0, 0.7e0, 0.8e0/
183 DATA strue4/0.0e0, 0.7e0, 1.0e0, 1.3e0, 1.6e0/
184 DATA ((ctrue5(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
185 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
186 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
187 + (1.0e0,2.0e0), (-0.16e0,-0.37e0), (3.0e0,4.0e0),
188 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
189 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
190 + (-0.17e0,-0.19e0), (0.13e0,-0.39e0),
191 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
192 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
193 + (0.11e0,-0.03e0), (-0.17e0,0.46e0),
194 + (-0.17e0,-0.19e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
195 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
196 + (0.19e0,-0.17e0), (0.20e0,-0.35e0),
197 + (0.35e0,0.20e0), (0.14e0,0.08e0),
198 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0),
199 + (2.0e0,3.0e0)/
200 DATA ((ctrue5(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
201 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
202 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
203 + (4.0e0,5.0e0), (-0.16e0,-0.37e0), (6.0e0,7.0e0),
204 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
205 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
206 + (-0.17e0,-0.19e0), (8.0e0,9.0e0),
207 + (0.13e0,-0.39e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
208 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
209 + (0.11e0,-0.03e0), (3.0e0,6.0e0),
210 + (-0.17e0,0.46e0), (4.0e0,7.0e0),
211 + (-0.17e0,-0.19e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
212 + (7.0e0,2.0e0), (0.19e0,-0.17e0), (5.0e0,8.0e0),
213 + (0.20e0,-0.35e0), (6.0e0,9.0e0),
214 + (0.35e0,0.20e0), (8.0e0,3.0e0),
215 + (0.14e0,0.08e0), (9.0e0,4.0e0)/
216 DATA ((ctrue6(i,j,1),i=1,8),j=1,5)/(0.1e0,0.1e0),
217 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
218 + (1.0e0,2.0e0), (1.0e0,2.0e0), (1.0e0,2.0e0),
219 + (1.0e0,2.0e0), (0.09e0,-0.12e0), (3.0e0,4.0e0),
220 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
221 + (3.0e0,4.0e0), (3.0e0,4.0e0), (3.0e0,4.0e0),
222 + (0.03e0,-0.09e0), (0.15e0,-0.03e0),
223 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
224 + (5.0e0,6.0e0), (5.0e0,6.0e0), (5.0e0,6.0e0),
225 + (0.03e0,0.03e0), (-0.18e0,0.03e0),
226 + (0.03e0,-0.09e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
227 + (7.0e0,8.0e0), (7.0e0,8.0e0), (7.0e0,8.0e0),
228 + (0.09e0,0.03e0), (0.15e0,0.00e0),
229 + (0.00e0,0.15e0), (0.00e0,0.06e0), (2.0e0,3.0e0),
230 + (2.0e0,3.0e0), (2.0e0,3.0e0), (2.0e0,3.0e0)/
231 DATA ((ctrue6(i,j,2),i=1,8),j=1,5)/(0.1e0,0.1e0),
232 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
233 + (4.0e0,5.0e0), (4.0e0,5.0e0), (4.0e0,5.0e0),
234 + (4.0e0,5.0e0), (0.09e0,-0.12e0), (6.0e0,7.0e0),
235 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
236 + (6.0e0,7.0e0), (6.0e0,7.0e0), (6.0e0,7.0e0),
237 + (0.03e0,-0.09e0), (8.0e0,9.0e0),
238 + (0.15e0,-0.03e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
239 + (2.0e0,5.0e0), (2.0e0,5.0e0), (2.0e0,5.0e0),
240 + (0.03e0,0.03e0), (3.0e0,6.0e0),
241 + (-0.18e0,0.03e0), (4.0e0,7.0e0),
242 + (0.03e0,-0.09e0), (7.0e0,2.0e0), (7.0e0,2.0e0),
243 + (7.0e0,2.0e0), (0.09e0,0.03e0), (5.0e0,8.0e0),
244 + (0.15e0,0.00e0), (6.0e0,9.0e0), (0.00e0,0.15e0),
245 + (8.0e0,3.0e0), (0.00e0,0.06e0), (9.0e0,4.0e0)/
246 DATA itrue3/0, 1, 2, 2, 2/
247 DATA itruec/0, 1, 1, 1, 1/
248* .. Executable Statements ..
249 DO 60 incx = 1, 2
250 DO 40 np1 = 1, 5
251 n = np1 - 1
252 len = 2*max(n,1)
253* .. Set vector arguments ..
254 DO 20 i = 1, len
255 cx(i) = cv(i,np1,incx)
256 20 CONTINUE
257 IF (icase.EQ.6) THEN
258* .. SCNRM2 ..
259 CALL stest1(scnrm2(n,cx,incx),strue2(np1),strue2(np1),
260 + sfac)
261 ELSE IF (icase.EQ.7) THEN
262* .. SCASUM ..
263 CALL stest1(scasum(n,cx,incx),strue4(np1),strue4(np1),
264 + sfac)
265 ELSE IF (icase.EQ.8) THEN
266* .. CSCAL ..
267 CALL cscal(n,ca,cx,incx)
268 CALL ctest(len,cx,ctrue5(1,np1,incx),ctrue5(1,np1,incx),
269 + sfac)
270 ELSE IF (icase.EQ.9) THEN
271* .. CSSCAL ..
272 CALL csscal(n,sa,cx,incx)
273 CALL ctest(len,cx,ctrue6(1,np1,incx),ctrue6(1,np1,incx),
274 + sfac)
275 ELSE IF (icase.EQ.10) THEN
276* .. ICAMAX ..
277 CALL itest1(icamax(n,cx,incx),itrue3(np1))
278 DO 160 i = 1, len
279 cx(i) = (42.0e0,43.0e0)
280 160 CONTINUE
281 CALL itest1(icamax(n,cx,incx),itruec(np1))
282 ELSE
283 WRITE (nout,*) ' Shouldn''t be here in CHECK1'
284 stop
285 END IF
286*
287 40 CONTINUE
288 IF (icase.EQ.10) THEN
289 n = 8
290 ix = 1
291 DO 180 i = 1, n
292 cxr(ix) = cvr(i)
293 ix = ix + incx
294 180 CONTINUE
295 CALL itest1(icamax(n,cxr,incx),3)
296 END IF
297 60 CONTINUE
298*
299 incx = 1
300 IF (icase.EQ.8) THEN
301* CSCAL
302* Add a test for alpha equal to zero.
303 ca = (0.0e0,0.0e0)
304 DO 80 i = 1, 5
305 mwpct(i) = (0.0e0,0.0e0)
306 mwpcs(i) = (1.0e0,1.0e0)
307 80 CONTINUE
308 CALL cscal(5,ca,cx,incx)
309 CALL ctest(5,cx,mwpct,mwpcs,sfac)
310 ELSE IF (icase.EQ.9) THEN
311* CSSCAL
312* Add a test for alpha equal to zero.
313 sa = 0.0e0
314 DO 100 i = 1, 5
315 mwpct(i) = (0.0e0,0.0e0)
316 mwpcs(i) = (1.0e0,1.0e0)
317 100 CONTINUE
318 CALL csscal(5,sa,cx,incx)
319 CALL ctest(5,cx,mwpct,mwpcs,sfac)
320* Add a test for alpha equal to one.
321 sa = 1.0e0
322 DO 120 i = 1, 5
323 mwpct(i) = cx(i)
324 mwpcs(i) = cx(i)
325 120 CONTINUE
326 CALL csscal(5,sa,cx,incx)
327 CALL ctest(5,cx,mwpct,mwpcs,sfac)
328* Add a test for alpha equal to minus one.
329 sa = -1.0e0
330 DO 140 i = 1, 5
331 mwpct(i) = -cx(i)
332 mwpcs(i) = -cx(i)
333 140 CONTINUE
334 CALL csscal(5,sa,cx,incx)
335 CALL ctest(5,cx,mwpct,mwpcs,sfac)
336 END IF
337 RETURN
338*
339* End of CHECK1
340*
ctest
subroutine ctest(len, ccomp, ctrue, csize, sfac)
Definition cblat1.f:709
stest1
subroutine stest1(scomp1, strue1, ssize, sfac)
Definition cblat1.f:668
itest1
subroutine itest1(icomp, itrue)
Definition cblat1.f:743
icamax
integer function icamax(n, cx, incx)
ICAMAX
Definition icamax.f:71
csscal
subroutine csscal(n, sa, cx, incx)
CSSCAL
Definition csscal.f:78
cscal
subroutine cscal(n, ca, cx, incx)
CSCAL
Definition cscal.f:78
scasum
real function scasum(n, cx, incx)
SCASUM
Definition scasum.f:72
scnrm2
real(wp) function scnrm2(n, x, incx)
SCNRM2
Definition scnrm2.f90:90
max
#define max(a, b)
Definition macros.h:21

◆ check2()

subroutine check2 ( real sfac)

Definition at line 342 of file cblat1.f.

343* .. Parameters ..
344 INTEGER NOUT
345 parameter(nout=6)
346* .. Scalar Arguments ..
347 REAL SFAC
348* .. Scalars in Common ..
349 INTEGER ICASE, INCX, INCY, MODE, N
350 LOGICAL PASS
351* .. Local Scalars ..
352 COMPLEX CA
353 INTEGER I, J, KI, KN, KSIZE, LENX, LENY, LINCX, LINCY,
354 + MX, MY
355* .. Local Arrays ..
356 COMPLEX CDOT(1), CSIZE1(4), CSIZE2(7,2), CSIZE3(14),
357 + CT10X(7,4,4), CT10Y(7,4,4), CT6(4,4), CT7(4,4),
358 + CT8(7,4,4), CTY0(1), CX(7), CX0(1), CX1(7),
359 + CY(7), CY0(1), CY1(7)
360 INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
361* .. External Functions ..
362 COMPLEX CDOTC, CDOTU
363 EXTERNAL cdotc, cdotu
364* .. External Subroutines ..
365 EXTERNAL caxpy, ccopy, cswap, ctest
366* .. Intrinsic Functions ..
367 INTRINSIC abs, min
368* .. Common blocks ..
369 COMMON /combla/icase, n, incx, incy, mode, pass
370* .. Data statements ..
371 DATA ca/(0.4e0,-0.7e0)/
372 DATA incxs/1, 2, -2, -1/
373 DATA incys/1, -2, 1, -2/
374 DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
375 DATA ns/0, 1, 2, 4/
376 DATA cx1/(0.7e0,-0.8e0), (-0.4e0,-0.7e0),
377 + (-0.1e0,-0.9e0), (0.2e0,-0.8e0),
378 + (-0.9e0,-0.4e0), (0.1e0,0.4e0), (-0.6e0,0.6e0)/
379 DATA cy1/(0.6e0,-0.6e0), (-0.9e0,0.5e0),
380 + (0.7e0,-0.6e0), (0.1e0,-0.5e0), (-0.1e0,-0.2e0),
381 + (-0.5e0,-0.3e0), (0.8e0,-0.7e0)/
382 DATA ((ct8(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
383 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
384 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
385 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
386 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
387 + (0.0e0,0.0e0), (0.32e0,-1.41e0),
388 + (-1.55e0,0.5e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
389 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
390 + (0.32e0,-1.41e0), (-1.55e0,0.5e0),
391 + (0.03e0,-0.89e0), (-0.38e0,-0.96e0),
392 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
393 DATA ((ct8(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
394 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
395 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
396 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
397 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
398 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
399 + (-0.9e0,0.5e0), (0.42e0,-1.41e0), (0.0e0,0.0e0),
400 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
401 + (0.78e0,0.06e0), (-0.9e0,0.5e0),
402 + (0.06e0,-0.13e0), (0.1e0,-0.5e0),
403 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
404 + (0.52e0,-1.51e0)/
405 DATA ((ct8(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
406 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
407 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
408 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
409 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
410 + (0.0e0,0.0e0), (-0.07e0,-0.89e0),
411 + (-1.18e0,-0.31e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
412 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
413 + (0.78e0,0.06e0), (-1.54e0,0.97e0),
414 + (0.03e0,-0.89e0), (-0.18e0,-1.31e0),
415 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
416 DATA ((ct8(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
417 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
418 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
419 + (0.32e0,-1.41e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
420 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
421 + (0.0e0,0.0e0), (0.32e0,-1.41e0), (-0.9e0,0.5e0),
422 + (0.05e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
423 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.32e0,-1.41e0),
424 + (-0.9e0,0.5e0), (0.05e0,-0.6e0), (0.1e0,-0.5e0),
425 + (-0.77e0,-0.49e0), (-0.5e0,-0.3e0),
426 + (0.32e0,-1.16e0)/
427 DATA ct7/(0.0e0,0.0e0), (-0.06e0,-0.90e0),
428 + (0.65e0,-0.47e0), (-0.34e0,-1.22e0),
429 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
430 + (-0.59e0,-1.46e0), (-1.04e0,-0.04e0),
431 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
432 + (-0.83e0,0.59e0), (0.07e0,-0.37e0),
433 + (0.0e0,0.0e0), (-0.06e0,-0.90e0),
434 + (-0.76e0,-1.15e0), (-1.33e0,-1.82e0)/
435 DATA ct6/(0.0e0,0.0e0), (0.90e0,0.06e0),
436 + (0.91e0,-0.77e0), (1.80e0,-0.10e0),
437 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.45e0,0.74e0),
438 + (0.20e0,0.90e0), (0.0e0,0.0e0), (0.90e0,0.06e0),
439 + (-0.55e0,0.23e0), (0.83e0,-0.39e0),
440 + (0.0e0,0.0e0), (0.90e0,0.06e0), (1.04e0,0.79e0),
441 + (1.95e0,1.22e0)/
442 DATA ((ct10x(i,j,1),i=1,7),j=1,4)/(0.7e0,-0.8e0),
443 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
444 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
445 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
446 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
447 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (-0.9e0,0.5e0),
448 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
449 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
450 + (-0.9e0,0.5e0), (0.7e0,-0.6e0), (0.1e0,-0.5e0),
451 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
452 DATA ((ct10x(i,j,2),i=1,7),j=1,4)/(0.7e0,-0.8e0),
453 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
454 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
455 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
456 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
457 + (0.0e0,0.0e0), (0.7e0,-0.6e0), (-0.4e0,-0.7e0),
458 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
459 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.8e0,-0.7e0),
460 + (-0.4e0,-0.7e0), (-0.1e0,-0.2e0),
461 + (0.2e0,-0.8e0), (0.7e0,-0.6e0), (0.1e0,0.4e0),
462 + (0.6e0,-0.6e0)/
463 DATA ((ct10x(i,j,3),i=1,7),j=1,4)/(0.7e0,-0.8e0),
464 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
465 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
466 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
467 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
468 + (0.0e0,0.0e0), (-0.9e0,0.5e0), (-0.4e0,-0.7e0),
469 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
470 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.1e0,-0.5e0),
471 + (-0.4e0,-0.7e0), (0.7e0,-0.6e0), (0.2e0,-0.8e0),
472 + (-0.9e0,0.5e0), (0.1e0,0.4e0), (0.6e0,-0.6e0)/
473 DATA ((ct10x(i,j,4),i=1,7),j=1,4)/(0.7e0,-0.8e0),
474 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
475 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
476 + (0.6e0,-0.6e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
477 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
478 + (0.0e0,0.0e0), (0.6e0,-0.6e0), (0.7e0,-0.6e0),
479 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
480 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.6e0,-0.6e0),
481 + (0.7e0,-0.6e0), (-0.1e0,-0.2e0), (0.8e0,-0.7e0),
482 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0)/
483 DATA ((ct10y(i,j,1),i=1,7),j=1,4)/(0.6e0,-0.6e0),
484 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
485 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
486 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
487 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
488 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.4e0,-0.7e0),
489 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
490 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
491 + (-0.4e0,-0.7e0), (-0.1e0,-0.9e0),
492 + (0.2e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
493 + (0.0e0,0.0e0)/
494 DATA ((ct10y(i,j,2),i=1,7),j=1,4)/(0.6e0,-0.6e0),
495 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
496 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
497 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
498 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
499 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (-0.9e0,0.5e0),
500 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
501 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
502 + (-0.9e0,0.5e0), (-0.9e0,-0.4e0), (0.1e0,-0.5e0),
503 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
504 + (0.7e0,-0.8e0)/
505 DATA ((ct10y(i,j,3),i=1,7),j=1,4)/(0.6e0,-0.6e0),
506 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
507 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
508 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
509 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
510 + (0.0e0,0.0e0), (-0.1e0,-0.9e0), (0.7e0,-0.8e0),
511 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
512 + (0.0e0,0.0e0), (0.0e0,0.0e0), (-0.6e0,0.6e0),
513 + (-0.9e0,-0.4e0), (-0.1e0,-0.9e0),
514 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
515 + (0.0e0,0.0e0)/
516 DATA ((ct10y(i,j,4),i=1,7),j=1,4)/(0.6e0,-0.6e0),
517 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
518 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
519 + (0.7e0,-0.8e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
520 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
521 + (0.0e0,0.0e0), (0.7e0,-0.8e0), (-0.9e0,0.5e0),
522 + (-0.4e0,-0.7e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
523 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.7e0,-0.8e0),
524 + (-0.9e0,0.5e0), (-0.4e0,-0.7e0), (0.1e0,-0.5e0),
525 + (-0.1e0,-0.9e0), (-0.5e0,-0.3e0),
526 + (0.2e0,-0.8e0)/
527 DATA csize1/(0.0e0,0.0e0), (0.9e0,0.9e0),
528 + (1.63e0,1.73e0), (2.90e0,2.78e0)/
529 DATA csize3/(0.0e0,0.0e0), (0.0e0,0.0e0),
530 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
531 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.17e0,1.17e0),
532 + (1.17e0,1.17e0), (1.17e0,1.17e0),
533 + (1.17e0,1.17e0), (1.17e0,1.17e0),
534 + (1.17e0,1.17e0), (1.17e0,1.17e0)/
535 DATA csize2/(0.0e0,0.0e0), (0.0e0,0.0e0),
536 + (0.0e0,0.0e0), (0.0e0,0.0e0), (0.0e0,0.0e0),
537 + (0.0e0,0.0e0), (0.0e0,0.0e0), (1.54e0,1.54e0),
538 + (1.54e0,1.54e0), (1.54e0,1.54e0),
539 + (1.54e0,1.54e0), (1.54e0,1.54e0),
540 + (1.54e0,1.54e0), (1.54e0,1.54e0)/
541* .. Executable Statements ..
542 DO 60 ki = 1, 4
543 incx = incxs(ki)
544 incy = incys(ki)
545 mx = abs(incx)
546 my = abs(incy)
547*
548 DO 40 kn = 1, 4
549 n = ns(kn)
550 ksize = min(2,kn)
551 lenx = lens(kn,mx)
552 leny = lens(kn,my)
553* .. initialize all argument arrays ..
554 DO 20 i = 1, 7
555 cx(i) = cx1(i)
556 cy(i) = cy1(i)
557 20 CONTINUE
558 IF (icase.EQ.1) THEN
559* .. CDOTC ..
560 cdot(1) = cdotc(n,cx,incx,cy,incy)
561 CALL ctest(1,cdot,ct6(kn,ki),csize1(kn),sfac)
562 ELSE IF (icase.EQ.2) THEN
563* .. CDOTU ..
564 cdot(1) = cdotu(n,cx,incx,cy,incy)
565 CALL ctest(1,cdot,ct7(kn,ki),csize1(kn),sfac)
566 ELSE IF (icase.EQ.3) THEN
567* .. CAXPY ..
568 CALL caxpy(n,ca,cx,incx,cy,incy)
569 CALL ctest(leny,cy,ct8(1,kn,ki),csize2(1,ksize),sfac)
570 ELSE IF (icase.EQ.4) THEN
571* .. CCOPY ..
572 CALL ccopy(n,cx,incx,cy,incy)
573 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
574 IF (ki.EQ.1) THEN
575 cx0(1) = (42.0e0,43.0e0)
576 cy0(1) = (44.0e0,45.0e0)
577 IF (n.EQ.0) THEN
578 cty0(1) = cy0(1)
579 ELSE
580 cty0(1) = cx0(1)
581 END IF
582 lincx = incx
583 incx = 0
584 lincy = incy
585 incy = 0
586 CALL ccopy(n,cx0,incx,cy0,incy)
587 CALL ctest(1,cy0,cty0,csize3,1.0e0)
588 incx = lincx
589 incy = lincy
590 END IF
591 ELSE IF (icase.EQ.5) THEN
592* .. CSWAP ..
593 CALL cswap(n,cx,incx,cy,incy)
594 CALL ctest(lenx,cx,ct10x(1,kn,ki),csize3,1.0e0)
595 CALL ctest(leny,cy,ct10y(1,kn,ki),csize3,1.0e0)
596 ELSE
597 WRITE (nout,*) ' Shouldn''t be here in CHECK2'
598 stop
599 END IF
600*
601 40 CONTINUE
602 60 CONTINUE
603 RETURN
604*
605* End of CHECK2
606*
caxpy
subroutine caxpy(n, ca, cx, incx, cy, incy)
CAXPY
Definition caxpy.f:88
cswap
subroutine cswap(n, cx, incx, cy, incy)
CSWAP
Definition cswap.f:81
cdotu
complex function cdotu(n, cx, incx, cy, incy)
CDOTU
Definition cdotu.f:83
cdotc
complex function cdotc(n, cx, incx, cy, incy)
CDOTC
Definition cdotc.f:83
ccopy
subroutine ccopy(n, cx, incx, cy, incy)
CCOPY
Definition ccopy.f:81
min
#define min(a, b)
Definition macros.h:20

◆ ctest()

subroutine ctest ( integer len,
complex, dimension(len) ccomp,
complex, dimension(len) ctrue,
complex, dimension(len) csize,
real sfac )

Definition at line 708 of file cblat1.f.

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

◆ header()

subroutine header

Definition at line 90 of file cblat1.f.

91* .. Parameters ..
92 INTEGER NOUT
93 parameter(nout=6)
94* .. Scalars in Common ..
95 INTEGER ICASE, INCX, INCY, MODE, N
96 LOGICAL PASS
97* .. Local Arrays ..
98 CHARACTER*6 L(10)
99* .. Common blocks ..
100 COMMON /combla/icase, n, incx, incy, mode, pass
101* .. Data statements ..
102 DATA l(1)/'CDOTC '/
103 DATA l(2)/'CDOTU '/
104 DATA l(3)/'CAXPY '/
105 DATA l(4)/'CCOPY '/
106 DATA l(5)/'CSWAP '/
107 DATA l(6)/'SCNRM2'/
108 DATA l(7)/'SCASUM'/
109 DATA l(8)/'CSCAL '/
110 DATA l(9)/'CSSCAL'/
111 DATA l(10)/'ICAMAX'/
112* .. Executable Statements ..
113 WRITE (nout,99999) icase, l(icase)
114 RETURN
115*
11699999 FORMAT (/' Test of subprogram number',i3,12x,a6)
117*
118* End of HEADER
119*

◆ itest1()

subroutine itest1 ( integer icomp,
integer itrue )

Definition at line 742 of file cblat1.f.

743* ********************************* ITEST1 *************************
744*
745* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
746* EQUALITY.
747* C. L. LAWSON, JPL, 1974 DEC 10
748*
749* .. Parameters ..
750 INTEGER NOUT
751 parameter(nout=6)
752* .. Scalar Arguments ..
753 INTEGER ICOMP, ITRUE
754* .. Scalars in Common ..
755 INTEGER ICASE, INCX, INCY, MODE, N
756 LOGICAL PASS
757* .. Local Scalars ..
758 INTEGER ID
759* .. Common blocks ..
760 COMMON /combla/icase, n, incx, incy, mode, pass
761* .. Executable Statements ..
762 IF (icomp.EQ.itrue) GO TO 40
763*
764* HERE ICOMP IS NOT EQUAL TO ITRUE.
765*
766 IF ( .NOT. pass) GO TO 20
767* PRINT FAIL MESSAGE AND HEADER.
768 pass = .false.
769 WRITE (nout,99999)
770 WRITE (nout,99998)
771 20 id = icomp - itrue
772 WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
773 40 CONTINUE
774 RETURN
775*
77699999 FORMAT (' FAIL')
77799998 FORMAT (/' CASE N INCX INCY MODE ',
778 + ' COMP TRUE DIFFERENCE',
779 + /1x)
78099997 FORMAT (1x,i4,i3,3i5,2i36,i12)
781*
782* End of ITEST1
783*
id
initmumps id
Definition multiplerhs_example.m:4

◆ sdiff()

real function sdiff ( real sa,
real sb )

Definition at line 695 of file cblat1.f.

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

◆ stest()

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

Definition at line 608 of file cblat1.f.

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

◆ stest1()

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

Definition at line 667 of file cblat1.f.

668* ************************* STEST1 *****************************
669*
670* THIS IS AN INTERFACE SUBROUTINE TO ACCOMMODATE THE FORTRAN
671* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
672* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
673*
674* C.L. LAWSON, JPL, 1978 DEC 6
675*
676* .. Scalar Arguments ..
677 REAL SCOMP1, SFAC, STRUE1
678* .. Array Arguments ..
679 REAL SSIZE(*)
680* .. Local Arrays ..
681 REAL SCOMP(1), STRUE(1)
682* .. External Subroutines ..
683 EXTERNAL stest
684* .. Executable Statements ..
685*
686 scomp(1) = scomp1
687 strue(1) = strue1
688 CALL stest(1,scomp,strue,ssize,sfac)
689*
690 RETURN
691*
692* End of STEST1
693*