LAPACK  3.5.0
LAPACK: Linear Algebra PACKage
sblat1.f File Reference

Go to the source code of this file.

Functions/Subroutines

program sblat1
 SBLAT1 More...
 
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

subroutine check0 ( real  SFAC)

Definition at line 127 of file sblat1.f.

127 * .. Parameters ..
128  INTEGER nout
129  parameter(nout=6)
130 * .. Scalar Arguments ..
131  REAL sfac
132 * .. Scalars in Common ..
133  INTEGER icase, incx, incy, n
134  LOGICAL pass
135 * .. Local Scalars ..
136  REAL d12, sa, sb, sc, ss
137  INTEGER i, k
138 * .. Local Arrays ..
139  REAL da1(8), datrue(8), db1(8), dbtrue(8), dc1(8),
140  + ds1(8), dab(4,9), dtemp(9), dtrue(9,9)
141 * .. External Subroutines ..
142  EXTERNAL srotg, srotmg, stest1
143 * .. Common blocks ..
144  COMMON /combla/icase, n, incx, incy, pass
145 * .. Data statements ..
146  DATA da1/0.3e0, 0.4e0, -0.3e0, -0.4e0, -0.3e0, 0.0e0,
147  + 0.0e0, 1.0e0/
148  DATA db1/0.4e0, 0.3e0, 0.4e0, 0.3e0, -0.4e0, 0.0e0,
149  + 1.0e0, 0.0e0/
150  DATA dc1/0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.6e0, 1.0e0,
151  + 0.0e0, 1.0e0/
152  DATA ds1/0.8e0, 0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.0e0,
153  + 1.0e0, 0.0e0/
154  DATA datrue/0.5e0, 0.5e0, 0.5e0, -0.5e0, -0.5e0,
155  + 0.0e0, 1.0e0, 1.0e0/
156  DATA dbtrue/0.0e0, 0.6e0, 0.0e0, -0.6e0, 0.0e0,
157  + 0.0e0, 1.0e0, 0.0e0/
158 * INPUT FOR MODIFIED GIVENS
159  DATA dab/ .1e0,.3e0,1.2e0,.2e0,
160  a .7e0, .2e0, .6e0, 4.2e0,
161  b 0.e0,0.e0,0.e0,0.e0,
162  c 4.e0, -1.e0, 2.e0, 4.e0,
163  d 6.e-10, 2.e-2, 1.e5, 10.e0,
164  e 4.e10, 2.e-2, 1.e-5, 10.e0,
165  f 2.e-10, 4.e-2, 1.e5, 10.e0,
166  g 2.e10, 4.e-2, 1.e-5, 10.e0,
167  h 4.e0, -2.e0, 8.e0, 4.e0 /
168 * TRUE RESULTS FOR MODIFIED GIVENS
169  DATA dtrue/0.e0,0.e0, 1.3e0, .2e0, 0.e0,0.e0,0.e0, .5e0, 0.e0,
170  a 0.e0,0.e0, 4.5e0, 4.2e0, 1.e0, .5e0, 0.e0,0.e0,0.e0,
171  b 0.e0,0.e0,0.e0,0.e0, -2.e0, 0.e0,0.e0,0.e0,0.e0,
172  c 0.e0,0.e0,0.e0, 4.e0, -1.e0, 0.e0,0.e0,0.e0,0.e0,
173  d 0.e0, 15.e-3, 0.e0, 10.e0, -1.e0, 0.e0, -1.e-4,
174  e 0.e0, 1.e0,
175  f 0.e0,0.e0, 6144.e-5, 10.e0, -1.e0, 4096.e0, -1.e6,
176  g 0.e0, 1.e0,
177  h 0.e0,0.e0,15.e0,10.e0,-1.e0, 5.e-5, 0.e0,1.e0,0.e0,
178  i 0.e0,0.e0, 15.e0, 10.e0, -1. e0, 5.e5, -4096.e0,
179  j 1.e0, 4096.e-6,
180  k 0.e0,0.e0, 7.e0, 4.e0, 0.e0,0.e0, -.5e0, -.25e0, 0.e0/
181 * 4096 = 2 ** 12
182  DATA d12 /4096.e0/
183  dtrue(1,1) = 12.e0 / 130.e0
184  dtrue(2,1) = 36.e0 / 130.e0
185  dtrue(7,1) = -1.e0 / 6.e0
186  dtrue(1,2) = 14.e0 / 75.e0
187  dtrue(2,2) = 49.e0 / 75.e0
188  dtrue(9,2) = 1.e0 / 7.e0
189  dtrue(1,5) = 45.e-11 * (d12 * d12)
190  dtrue(3,5) = 4.e5 / (3.e0 * d12)
191  dtrue(6,5) = 1.e0 / d12
192  dtrue(8,5) = 1.e4 / (3.e0 * d12)
193  dtrue(1,6) = 4.e10 / (1.5e0 * d12 * d12)
194  dtrue(2,6) = 2.e-2 / 1.5e0
195  dtrue(8,6) = 5.e-7 * d12
196  dtrue(1,7) = 4.e0 / 150.e0
197  dtrue(2,7) = (2.e-10 / 1.5e0) * (d12 * d12)
198  dtrue(7,7) = -dtrue(6,5)
199  dtrue(9,7) = 1.e4 / d12
200  dtrue(1,8) = dtrue(1,7)
201  dtrue(2,8) = 2.e10 / (1.5e0 * d12 * d12)
202  dtrue(1,9) = 32.e0 / 7.e0
203  dtrue(2,9) = -16.e0 / 7.e0
204 * .. Executable Statements ..
205 *
206 * Compute true values which cannot be prestored
207 * in decimal notation
208 *
209  dbtrue(1) = 1.0e0/0.6e0
210  dbtrue(3) = -1.0e0/0.6e0
211  dbtrue(5) = 1.0e0/0.6e0
212 *
213  DO 20 k = 1, 8
214 * .. Set N=K for identification in output if any ..
215  n = k
216  IF (icase.EQ.3) THEN
217 * .. SROTG ..
218  IF (k.GT.8) GO TO 40
219  sa = da1(k)
220  sb = db1(k)
221  CALL srotg(sa,sb,sc,ss)
222  CALL stest1(sa,datrue(k),datrue(k),sfac)
223  CALL stest1(sb,dbtrue(k),dbtrue(k),sfac)
224  CALL stest1(sc,dc1(k),dc1(k),sfac)
225  CALL stest1(ss,ds1(k),ds1(k),sfac)
226  ELSEIF (icase.EQ.11) THEN
227 * .. SROTMG ..
228  DO i=1,4
229  dtemp(i)= dab(i,k)
230  dtemp(i+4) = 0.0
231  END DO
232  dtemp(9) = 0.0
233  CALL srotmg(dtemp(1),dtemp(2),dtemp(3),dtemp(4),dtemp(5))
234  CALL stest(9,dtemp,dtrue(1,k),dtrue(1,k),sfac)
235  ELSE
236  WRITE (nout,*) ' Shouldn''t be here in CHECK0'
237  stop
238  END IF
239  20 CONTINUE
240  40 RETURN
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:620
subroutine srotg(SA, SB, C, S)
SROTG
Definition: srotg.f:48
subroutine srotmg(SD1, SD2, SX1, SY1, SPARAM)
SROTMG
Definition: srotmg.f:92

Here is the call graph for this function:

subroutine check1 ( real  SFAC)

Definition at line 243 of file sblat1.f.

243 * .. Parameters ..
244  INTEGER nout
245  parameter(nout=6)
246 * .. Scalar Arguments ..
247  REAL sfac
248 * .. Scalars in Common ..
249  INTEGER icase, incx, incy, n
250  LOGICAL pass
251 * .. Local Scalars ..
252  INTEGER i, len, np1
253 * .. Local Arrays ..
254  REAL dtrue1(5), dtrue3(5), dtrue5(8,5,2), dv(8,5,2),
255  + sa(10), stemp(1), strue(8), sx(8)
256  INTEGER itrue2(5)
257 * .. External Functions ..
258  REAL sasum, snrm2
259  INTEGER isamax
260  EXTERNAL sasum, snrm2, isamax
261 * .. External Subroutines ..
262  EXTERNAL itest1, sscal, stest, stest1
263 * .. Intrinsic Functions ..
264  INTRINSIC max
265 * .. Common blocks ..
266  COMMON /combla/icase, n, incx, incy, pass
267 * .. Data statements ..
268  DATA sa/0.3e0, -1.0e0, 0.0e0, 1.0e0, 0.3e0, 0.3e0,
269  + 0.3e0, 0.3e0, 0.3e0, 0.3e0/
270  DATA dv/0.1e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
271  + 2.0e0, 2.0e0, 0.3e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0,
272  + 3.0e0, 3.0e0, 3.0e0, 0.3e0, -0.4e0, 4.0e0,
273  + 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 0.2e0,
274  + -0.6e0, 0.3e0, 5.0e0, 5.0e0, 5.0e0, 5.0e0,
275  + 5.0e0, 0.1e0, -0.3e0, 0.5e0, -0.1e0, 6.0e0,
276  + 6.0e0, 6.0e0, 6.0e0, 0.1e0, 8.0e0, 8.0e0, 8.0e0,
277  + 8.0e0, 8.0e0, 8.0e0, 8.0e0, 0.3e0, 9.0e0, 9.0e0,
278  + 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 0.3e0, 2.0e0,
279  + -0.4e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
280  + 0.2e0, 3.0e0, -0.6e0, 5.0e0, 0.3e0, 2.0e0,
281  + 2.0e0, 2.0e0, 0.1e0, 4.0e0, -0.3e0, 6.0e0,
282  + -0.5e0, 7.0e0, -0.1e0, 3.0e0/
283  DATA dtrue1/0.0e0, 0.3e0, 0.5e0, 0.7e0, 0.6e0/
284  DATA dtrue3/0.0e0, 0.3e0, 0.7e0, 1.1e0, 1.0e0/
285  DATA dtrue5/0.10e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
286  + 2.0e0, 2.0e0, 2.0e0, -0.3e0, 3.0e0, 3.0e0,
287  + 3.0e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0, 0.0e0, 0.0e0,
288  + 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0,
289  + 0.20e0, -0.60e0, 0.30e0, 5.0e0, 5.0e0, 5.0e0,
290  + 5.0e0, 5.0e0, 0.03e0, -0.09e0, 0.15e0, -0.03e0,
291  + 6.0e0, 6.0e0, 6.0e0, 6.0e0, 0.10e0, 8.0e0,
292  + 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0,
293  + 0.09e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0,
294  + 9.0e0, 9.0e0, 0.09e0, 2.0e0, -0.12e0, 2.0e0,
295  + 2.0e0, 2.0e0, 2.0e0, 2.0e0, 0.06e0, 3.0e0,
296  + -0.18e0, 5.0e0, 0.09e0, 2.0e0, 2.0e0, 2.0e0,
297  + 0.03e0, 4.0e0, -0.09e0, 6.0e0, -0.15e0, 7.0e0,
298  + -0.03e0, 3.0e0/
299  DATA itrue2/0, 1, 2, 2, 3/
300 * .. Executable Statements ..
301  DO 80 incx = 1, 2
302  DO 60 np1 = 1, 5
303  n = np1 - 1
304  len = 2*max(n,1)
305 * .. Set vector arguments ..
306  DO 20 i = 1, len
307  sx(i) = dv(i,np1,incx)
308  20 CONTINUE
309 *
310  IF (icase.EQ.7) THEN
311 * .. SNRM2 ..
312  stemp(1) = dtrue1(np1)
313  CALL stest1(snrm2(n,sx,incx),stemp(1),stemp,sfac)
314  ELSE IF (icase.EQ.8) THEN
315 * .. SASUM ..
316  stemp(1) = dtrue3(np1)
317  CALL stest1(sasum(n,sx,incx),stemp(1),stemp,sfac)
318  ELSE IF (icase.EQ.9) THEN
319 * .. SSCAL ..
320  CALL sscal(n,sa((incx-1)*5+np1),sx,incx)
321  DO 40 i = 1, len
322  strue(i) = dtrue5(i,np1,incx)
323  40 CONTINUE
324  CALL stest(len,sx,strue,strue,sfac)
325  ELSE IF (icase.EQ.10) THEN
326 * .. ISAMAX ..
327  CALL itest1(isamax(n,sx,incx),itrue2(np1))
328  ELSE
329  WRITE (nout,*) ' Shouldn''t be here in CHECK1'
330  stop
331  END IF
332  60 CONTINUE
333  80 CONTINUE
334  RETURN
integer function isamax(N, SX, INCX)
ISAMAX
Definition: isamax.f:53
subroutine itest1(ICOMP, ITRUE)
Definition: cblat1.f:686
real function sasum(N, SX, INCX)
SASUM
Definition: sasum.f:54
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:620
real function snrm2(N, X, INCX)
SNRM2
Definition: snrm2.f:56
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:55

Here is the call graph for this function:

subroutine check2 ( real  SFAC)

Definition at line 337 of file sblat1.f.

337 * .. Parameters ..
338  INTEGER nout
339  parameter(nout=6)
340 * .. Scalar Arguments ..
341  REAL sfac
342 * .. Scalars in Common ..
343  INTEGER icase, incx, incy, n
344  LOGICAL pass
345 * .. Local Scalars ..
346  REAL sa
347  INTEGER i, j, ki, kn, kni, kpar, ksize, lenx, leny,
348  $ mx, my
349 * .. Local Arrays ..
350  REAL dt10x(7,4,4), dt10y(7,4,4), dt7(4,4),
351  $ dt8(7,4,4), dx1(7),
352  $ dy1(7), ssize1(4), ssize2(14,2), ssize3(4),
353  $ ssize(7), stx(7), sty(7), sx(7), sy(7),
354  $ dpar(5,4), dt19x(7,4,16),dt19xa(7,4,4),
355  $ dt19xb(7,4,4), dt19xc(7,4,4),dt19xd(7,4,4),
356  $ dt19y(7,4,16), dt19ya(7,4,4),dt19yb(7,4,4),
357  $ dt19yc(7,4,4), dt19yd(7,4,4), dtemp(5),
358  $ st7b(4,4)
359  INTEGER incxs(4), incys(4), lens(4,2), ns(4)
360 * .. External Functions ..
361  REAL sdot, sdsdot
362  EXTERNAL sdot, sdsdot
363 * .. External Subroutines ..
364  EXTERNAL saxpy, scopy, srotm, sswap, stest, stest1
365 * .. Intrinsic Functions ..
366  INTRINSIC abs, min
367 * .. Common blocks ..
368  COMMON /combla/icase, n, incx, incy, pass
369 * .. Data statements ..
370  equivalence(dt19x(1,1,1),dt19xa(1,1,1)),(dt19x(1,1,5),
371  a dt19xb(1,1,1)),(dt19x(1,1,9),dt19xc(1,1,1)),
372  b (dt19x(1,1,13),dt19xd(1,1,1))
373  equivalence(dt19y(1,1,1),dt19ya(1,1,1)),(dt19y(1,1,5),
374  a dt19yb(1,1,1)),(dt19y(1,1,9),dt19yc(1,1,1)),
375  b (dt19y(1,1,13),dt19yd(1,1,1))
376 
377  DATA sa/0.3e0/
378  DATA incxs/1, 2, -2, -1/
379  DATA incys/1, -2, 1, -2/
380  DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
381  DATA ns/0, 1, 2, 4/
382  DATA dx1/0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.9e0, -0.3e0,
383  + -0.4e0/
384  DATA dy1/0.5e0, -0.9e0, 0.3e0, 0.7e0, -0.6e0, 0.2e0,
385  + 0.8e0/
386  DATA dt7/0.0e0, 0.30e0, 0.21e0, 0.62e0, 0.0e0,
387  + 0.30e0, -0.07e0, 0.85e0, 0.0e0, 0.30e0, -0.79e0,
388  + -0.74e0, 0.0e0, 0.30e0, 0.33e0, 1.27e0/
389  DATA st7b/ .1, .4, .31, .72, .1, .4, .03, .95,
390  + .1, .4, -.69, -.64, .1, .4, .43, 1.37/
391  DATA dt8/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
392  + 0.0e0, 0.68e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
393  + 0.0e0, 0.0e0, 0.68e0, -0.87e0, 0.0e0, 0.0e0,
394  + 0.0e0, 0.0e0, 0.0e0, 0.68e0, -0.87e0, 0.15e0,
395  + 0.94e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
396  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.68e0,
397  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
398  + 0.35e0, -0.9e0, 0.48e0, 0.0e0, 0.0e0, 0.0e0,
399  + 0.0e0, 0.38e0, -0.9e0, 0.57e0, 0.7e0, -0.75e0,
400  + 0.2e0, 0.98e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0,
401  + 0.0e0, 0.0e0, 0.0e0, 0.68e0, 0.0e0, 0.0e0,
402  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.35e0, -0.72e0,
403  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.38e0,
404  + -0.63e0, 0.15e0, 0.88e0, 0.0e0, 0.0e0, 0.0e0,
405  + 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
406  + 0.68e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
407  + 0.0e0, 0.68e0, -0.9e0, 0.33e0, 0.0e0, 0.0e0,
408  + 0.0e0, 0.0e0, 0.68e0, -0.9e0, 0.33e0, 0.7e0,
409  + -0.75e0, 0.2e0, 1.04e0/
410  DATA dt10x/0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
411  + 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
412  + 0.0e0, 0.5e0, -0.9e0, 0.0e0, 0.0e0, 0.0e0,
413  + 0.0e0, 0.0e0, 0.5e0, -0.9e0, 0.3e0, 0.7e0,
414  + 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0,
415  + 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0,
416  + 0.0e0, 0.0e0, 0.0e0, 0.3e0, 0.1e0, 0.5e0, 0.0e0,
417  + 0.0e0, 0.0e0, 0.0e0, 0.8e0, 0.1e0, -0.6e0,
418  + 0.8e0, 0.3e0, -0.3e0, 0.5e0, 0.6e0, 0.0e0,
419  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
420  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.9e0,
421  + 0.1e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.7e0,
422  + 0.1e0, 0.3e0, 0.8e0, -0.9e0, -0.3e0, 0.5e0,
423  + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
424  + 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
425  + 0.5e0, 0.3e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
426  + 0.5e0, 0.3e0, -0.6e0, 0.8e0, 0.0e0, 0.0e0,
427  + 0.0e0/
428  DATA dt10y/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
429  + 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
430  + 0.0e0, 0.6e0, 0.1e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
431  + 0.0e0, 0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.0e0,
432  + 0.0e0, 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
433  + 0.0e0, 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
434  + 0.0e0, 0.0e0, -0.5e0, -0.9e0, 0.6e0, 0.0e0,
435  + 0.0e0, 0.0e0, 0.0e0, -0.4e0, -0.9e0, 0.9e0,
436  + 0.7e0, -0.5e0, 0.2e0, 0.6e0, 0.5e0, 0.0e0,
437  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0,
438  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.5e0,
439  + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
440  + -0.4e0, 0.9e0, -0.5e0, 0.6e0, 0.0e0, 0.0e0,
441  + 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
442  + 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
443  + 0.0e0, 0.6e0, -0.9e0, 0.1e0, 0.0e0, 0.0e0,
444  + 0.0e0, 0.0e0, 0.6e0, -0.9e0, 0.1e0, 0.7e0,
445  + -0.5e0, 0.2e0, 0.8e0/
446  DATA ssize1/0.0e0, 0.3e0, 1.6e0, 3.2e0/
447  DATA ssize2/0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
448  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
449  + 0.0e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
450  + 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
451  + 1.17e0, 1.17e0, 1.17e0/
452  DATA ssize3/ .1, .4, 1.7, 3.3 /
453 *
454 * FOR DROTM
455 *
456  DATA dpar/-2.e0, 0.e0,0.e0,0.e0,0.e0,
457  a -1.e0, 2.e0, -3.e0, -4.e0, 5.e0,
458  b 0.e0, 0.e0, 2.e0, -3.e0, 0.e0,
459  c 1.e0, 5.e0, 2.e0, 0.e0, -4.e0/
460 * TRUE X RESULTS F0R ROTATIONS DROTM
461  DATA dt19xa/.6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
462  a .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
463  b .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
464  c .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
465  d .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
466  e -.8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
467  f -.9e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
468  g 3.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
469  h .6e0, .1e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
470  i -.8e0, 3.8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
471  j -.9e0, 2.8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
472  k 3.5e0, -.4e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
473  l .6e0, .1e0, -.5e0, .8e0, 0.e0,0.e0,0.e0,
474  m -.8e0, 3.8e0, -2.2e0, -1.2e0, 0.e0,0.e0,0.e0,
475  n -.9e0, 2.8e0, -1.4e0, -1.3e0, 0.e0,0.e0,0.e0,
476  o 3.5e0, -.4e0, -2.2e0, 4.7e0, 0.e0,0.e0,0.e0/
477 *
478  DATA dt19xb/.6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
479  a .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
480  b .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
481  c .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
482  d .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
483  e -.8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
484  f -.9e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
485  g 3.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
486  h .6e0, .1e0, -.5e0, 0.e0,0.e0,0.e0,0.e0,
487  i 0.e0, .1e0, -3.0e0, 0.e0,0.e0,0.e0,0.e0,
488  j -.3e0, .1e0, -2.0e0, 0.e0,0.e0,0.e0,0.e0,
489  k 3.3e0, .1e0, -2.0e0, 0.e0,0.e0,0.e0,0.e0,
490  l .6e0, .1e0, -.5e0, .8e0, .9e0, -.3e0, -.4e0,
491  m -2.0e0, .1e0, 1.4e0, .8e0, .6e0, -.3e0, -2.8e0,
492  n -1.8e0, .1e0, 1.3e0, .8e0, 0.e0, -.3e0, -1.9e0,
493  o 3.8e0, .1e0, -3.1e0, .8e0, 4.8e0, -.3e0, -1.5e0 /
494 *
495  DATA dt19xc/.6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
496  a .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
497  b .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
498  c .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
499  d .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
500  e -.8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
501  f -.9e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
502  g 3.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
503  h .6e0, .1e0, -.5e0, 0.e0,0.e0,0.e0,0.e0,
504  i 4.8e0, .1e0, -3.0e0, 0.e0,0.e0,0.e0,0.e0,
505  j 3.3e0, .1e0, -2.0e0, 0.e0,0.e0,0.e0,0.e0,
506  k 2.1e0, .1e0, -2.0e0, 0.e0,0.e0,0.e0,0.e0,
507  l .6e0, .1e0, -.5e0, .8e0, .9e0, -.3e0, -.4e0,
508  m -1.6e0, .1e0, -2.2e0, .8e0, 5.4e0, -.3e0, -2.8e0,
509  n -1.5e0, .1e0, -1.4e0, .8e0, 3.6e0, -.3e0, -1.9e0,
510  o 3.7e0, .1e0, -2.2e0, .8e0, 3.6e0, -.3e0, -1.5e0 /
511 *
512  DATA dt19xd/.6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
513  a .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
514  b .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
515  c .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
516  d .6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
517  e -.8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
518  f -.9e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
519  g 3.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
520  h .6e0, .1e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
521  i -.8e0, -1.0e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
522  j -.9e0, -.8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
523  k 3.5e0, .8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
524  l .6e0, .1e0, -.5e0, .8e0, 0.e0,0.e0,0.e0,
525  m -.8e0, -1.0e0, 1.4e0, -1.6e0, 0.e0,0.e0,0.e0,
526  n -.9e0, -.8e0, 1.3e0, -1.6e0, 0.e0,0.e0,0.e0,
527  o 3.5e0, .8e0, -3.1e0, 4.8e0, 0.e0,0.e0,0.e0/
528 * TRUE Y RESULTS FOR ROTATIONS DROTM
529  DATA dt19ya/.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
530  a .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
531  b .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
532  c .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
533  d .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
534  e .7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
535  f 1.7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
536  g -2.6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
537  h .5e0, -.9e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
538  i .7e0, -4.8e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
539  j 1.7e0, -.7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
540  k -2.6e0, 3.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
541  l .5e0, -.9e0, .3e0, .7e0, 0.e0,0.e0,0.e0,
542  m .7e0, -4.8e0, 3.0e0, 1.1e0, 0.e0,0.e0,0.e0,
543  n 1.7e0, -.7e0, -.7e0, 2.3e0, 0.e0,0.e0,0.e0,
544  o -2.6e0, 3.5e0, -.7e0, -3.6e0, 0.e0,0.e0,0.e0/
545 *
546  DATA dt19yb/.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
547  a .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
548  b .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
549  c .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
550  d .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
551  e .7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
552  f 1.7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
553  g -2.6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
554  h .5e0, -.9e0, .3e0, 0.e0,0.e0,0.e0,0.e0,
555  i 4.0e0, -.9e0, -.3e0, 0.e0,0.e0,0.e0,0.e0,
556  j -.5e0, -.9e0, 1.5e0, 0.e0,0.e0,0.e0,0.e0,
557  k -1.5e0, -.9e0, -1.8e0, 0.e0,0.e0,0.e0,0.e0,
558  l .5e0, -.9e0, .3e0, .7e0, -.6e0, .2e0, .8e0,
559  m 3.7e0, -.9e0, -1.2e0, .7e0, -1.5e0, .2e0, 2.2e0,
560  n -.3e0, -.9e0, 2.1e0, .7e0, -1.6e0, .2e0, 2.0e0,
561  o -1.6e0, -.9e0, -2.1e0, .7e0, 2.9e0, .2e0, -3.8e0 /
562 *
563  DATA dt19yc/.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
564  a .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
565  b .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
566  c .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
567  d .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
568  e .7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
569  f 1.7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
570  g -2.6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
571  h .5e0, -.9e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
572  i 4.0e0, -6.3e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
573  j -.5e0, .3e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
574  k -1.5e0, 3.0e0, 0.e0,0.e0,0.e0,0.e0,0.e0,
575  l .5e0, -.9e0, .3e0, .7e0, 0.e0,0.e0,0.e0,
576  m 3.7e0, -7.2e0, 3.0e0, 1.7e0, 0.e0,0.e0,0.e0,
577  n -.3e0, .9e0, -.7e0, 1.9e0, 0.e0,0.e0,0.e0,
578  o -1.6e0, 2.7e0, -.7e0, -3.4e0, 0.e0,0.e0,0.e0/
579 *
580  DATA dt19yd/.5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
581  a .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
582  b .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
583  c .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
584  d .5e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
585  e .7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
586  f 1.7e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
587  g -2.6e0, 0.e0,0.e0,0.e0,0.e0,0.e0,0.e0,
588  h .5e0, -.9e0, .3e0, 0.e0,0.e0,0.e0,0.e0,
589  i .7e0, -.9e0, 1.2e0, 0.e0,0.e0,0.e0,0.e0,
590  j 1.7e0, -.9e0, .5e0, 0.e0,0.e0,0.e0,0.e0,
591  k -2.6e0, -.9e0, -1.3e0, 0.e0,0.e0,0.e0,0.e0,
592  l .5e0, -.9e0, .3e0, .7e0, -.6e0, .2e0, .8e0,
593  m .7e0, -.9e0, 1.2e0, .7e0, -1.5e0, .2e0, 1.6e0,
594  n 1.7e0, -.9e0, .5e0, .7e0, -1.6e0, .2e0, 2.4e0,
595  o -2.6e0, -.9e0, -1.3e0, .7e0, 2.9e0, .2e0, -4.0e0 /
596 *
597 * .. Executable Statements ..
598 *
599  DO 120 ki = 1, 4
600  incx = incxs(ki)
601  incy = incys(ki)
602  mx = abs(incx)
603  my = abs(incy)
604 *
605  DO 100 kn = 1, 4
606  n = ns(kn)
607  ksize = min(2,kn)
608  lenx = lens(kn,mx)
609  leny = lens(kn,my)
610 * .. Initialize all argument arrays ..
611  DO 20 i = 1, 7
612  sx(i) = dx1(i)
613  sy(i) = dy1(i)
614  20 CONTINUE
615 *
616  IF (icase.EQ.1) THEN
617 * .. SDOT ..
618  CALL stest1(sdot(n,sx,incx,sy,incy),dt7(kn,ki),ssize1(kn)
619  + ,sfac)
620  ELSE IF (icase.EQ.2) THEN
621 * .. SAXPY ..
622  CALL saxpy(n,sa,sx,incx,sy,incy)
623  DO 40 j = 1, leny
624  sty(j) = dt8(j,kn,ki)
625  40 CONTINUE
626  CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
627  ELSE IF (icase.EQ.5) THEN
628 * .. SCOPY ..
629  DO 60 i = 1, 7
630  sty(i) = dt10y(i,kn,ki)
631  60 CONTINUE
632  CALL scopy(n,sx,incx,sy,incy)
633  CALL stest(leny,sy,sty,ssize2(1,1),1.0e0)
634  ELSE IF (icase.EQ.6) THEN
635 * .. SSWAP ..
636  CALL sswap(n,sx,incx,sy,incy)
637  DO 80 i = 1, 7
638  stx(i) = dt10x(i,kn,ki)
639  sty(i) = dt10y(i,kn,ki)
640  80 CONTINUE
641  CALL stest(lenx,sx,stx,ssize2(1,1),1.0e0)
642  CALL stest(leny,sy,sty,ssize2(1,1),1.0e0)
643  ELSEIF (icase.EQ.12) THEN
644 * .. SROTM ..
645  kni=kn+4*(ki-1)
646  DO kpar=1,4
647  DO i=1,7
648  sx(i) = dx1(i)
649  sy(i) = dy1(i)
650  stx(i)= dt19x(i,kpar,kni)
651  sty(i)= dt19y(i,kpar,kni)
652  END DO
653 *
654  DO i=1,5
655  dtemp(i) = dpar(i,kpar)
656  END DO
657 *
658  DO i=1,lenx
659  ssize(i)=stx(i)
660  END DO
661 * SEE REMARK ABOVE ABOUT DT11X(1,2,7)
662 * AND DT11X(5,3,8).
663  IF ((kpar .EQ. 2) .AND. (kni .EQ. 7))
664  $ ssize(1) = 2.4e0
665  IF ((kpar .EQ. 3) .AND. (kni .EQ. 8))
666  $ ssize(5) = 1.8e0
667 *
668  CALL srotm(n,sx,incx,sy,incy,dtemp)
669  CALL stest(lenx,sx,stx,ssize,sfac)
670  CALL stest(leny,sy,sty,sty,sfac)
671  END DO
672  ELSEIF (icase.EQ.13) THEN
673 * .. SDSROT ..
674  CALL stest1 (sdsdot(n,.1,sx,incx,sy,incy),
675  $ st7b(kn,ki),ssize3(kn),sfac)
676  ELSE
677  WRITE (nout,*) ' Shouldn''t be here in CHECK2'
678  stop
679  END IF
680  100 CONTINUE
681  120 CONTINUE
682  RETURN
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
Definition: sswap.f:53
real function sdot(N, SX, INCX, SY, INCY)
SDOT
Definition: sdot.f:53
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564
subroutine srotm(N, SX, INCX, SY, INCY, SPARAM)
SROTM
Definition: srotm.f:101
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
Definition: scopy.f:53
subroutine saxpy(N, SA, SX, INCX, SY, INCY)
SAXPY
Definition: saxpy.f:54
real function sdsdot(N, SB, SX, INCX, SY, INCY)
SDSDOT
Definition: sdsdot.f:142
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:620

Here is the call graph for this function:

subroutine check3 ( real  SFAC)

Definition at line 685 of file sblat1.f.

685 * .. Parameters ..
686  INTEGER nout
687  parameter(nout=6)
688 * .. Scalar Arguments ..
689  REAL sfac
690 * .. Scalars in Common ..
691  INTEGER icase, incx, incy, n
692  LOGICAL pass
693 * .. Local Scalars ..
694  REAL sc, ss
695  INTEGER i, k, ki, kn, ksize, lenx, leny, mx, my
696 * .. Local Arrays ..
697  REAL copyx(5), copyy(5), dt9x(7,4,4), dt9y(7,4,4),
698  + dx1(7), dy1(7), mwpc(11), mwps(11), mwpstx(5),
699  + mwpsty(5), mwptx(11,5), mwpty(11,5), mwpx(5),
700  + mwpy(5), ssize2(14,2), stx(7), sty(7), sx(7),
701  + sy(7)
702  INTEGER incxs(4), incys(4), lens(4,2), mwpinx(11),
703  + mwpiny(11), mwpn(11), ns(4)
704 * .. External Subroutines ..
705  EXTERNAL srot, stest
706 * .. Intrinsic Functions ..
707  INTRINSIC abs, min
708 * .. Common blocks ..
709  COMMON /combla/icase, n, incx, incy, pass
710 * .. Data statements ..
711  DATA incxs/1, 2, -2, -1/
712  DATA incys/1, -2, 1, -2/
713  DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
714  DATA ns/0, 1, 2, 4/
715  DATA dx1/0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.9e0, -0.3e0,
716  + -0.4e0/
717  DATA dy1/0.5e0, -0.9e0, 0.3e0, 0.7e0, -0.6e0, 0.2e0,
718  + 0.8e0/
719  DATA sc, ss/0.8e0, 0.6e0/
720  DATA dt9x/0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
721  + 0.0e0, 0.78e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
722  + 0.0e0, 0.0e0, 0.78e0, -0.46e0, 0.0e0, 0.0e0,
723  + 0.0e0, 0.0e0, 0.0e0, 0.78e0, -0.46e0, -0.22e0,
724  + 1.06e0, 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0,
725  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.78e0,
726  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
727  + 0.66e0, 0.1e0, -0.1e0, 0.0e0, 0.0e0, 0.0e0,
728  + 0.0e0, 0.96e0, 0.1e0, -0.76e0, 0.8e0, 0.90e0,
729  + -0.3e0, -0.02e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0,
730  + 0.0e0, 0.0e0, 0.0e0, 0.78e0, 0.0e0, 0.0e0,
731  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.06e0, 0.1e0,
732  + -0.1e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.90e0,
733  + 0.1e0, -0.22e0, 0.8e0, 0.18e0, -0.3e0, -0.02e0,
734  + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
735  + 0.78e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
736  + 0.0e0, 0.78e0, 0.26e0, 0.0e0, 0.0e0, 0.0e0,
737  + 0.0e0, 0.0e0, 0.78e0, 0.26e0, -0.76e0, 1.12e0,
738  + 0.0e0, 0.0e0, 0.0e0/
739  DATA dt9y/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
740  + 0.0e0, 0.04e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
741  + 0.0e0, 0.0e0, 0.04e0, -0.78e0, 0.0e0, 0.0e0,
742  + 0.0e0, 0.0e0, 0.0e0, 0.04e0, -0.78e0, 0.54e0,
743  + 0.08e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
744  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.04e0,
745  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.7e0,
746  + -0.9e0, -0.12e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
747  + 0.64e0, -0.9e0, -0.30e0, 0.7e0, -0.18e0, 0.2e0,
748  + 0.28e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
749  + 0.0e0, 0.0e0, 0.04e0, 0.0e0, 0.0e0, 0.0e0,
750  + 0.0e0, 0.0e0, 0.0e0, 0.7e0, -1.08e0, 0.0e0,
751  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.64e0, -1.26e0,
752  + 0.54e0, 0.20e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0,
753  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
754  + 0.04e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
755  + 0.0e0, 0.04e0, -0.9e0, 0.18e0, 0.0e0, 0.0e0,
756  + 0.0e0, 0.0e0, 0.04e0, -0.9e0, 0.18e0, 0.7e0,
757  + -0.18e0, 0.2e0, 0.16e0/
758  DATA ssize2/0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
759  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
760  + 0.0e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
761  + 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
762  + 1.17e0, 1.17e0, 1.17e0/
763 * .. Executable Statements ..
764 *
765  DO 60 ki = 1, 4
766  incx = incxs(ki)
767  incy = incys(ki)
768  mx = abs(incx)
769  my = abs(incy)
770 *
771  DO 40 kn = 1, 4
772  n = ns(kn)
773  ksize = min(2,kn)
774  lenx = lens(kn,mx)
775  leny = lens(kn,my)
776 *
777  IF (icase.EQ.4) THEN
778 * .. SROT ..
779  DO 20 i = 1, 7
780  sx(i) = dx1(i)
781  sy(i) = dy1(i)
782  stx(i) = dt9x(i,kn,ki)
783  sty(i) = dt9y(i,kn,ki)
784  20 CONTINUE
785  CALL srot(n,sx,incx,sy,incy,sc,ss)
786  CALL stest(lenx,sx,stx,ssize2(1,ksize),sfac)
787  CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
788  ELSE
789  WRITE (nout,*) ' Shouldn''t be here in CHECK3'
790  stop
791  END IF
792  40 CONTINUE
793  60 CONTINUE
794 *
795  mwpc(1) = 1
796  DO 80 i = 2, 11
797  mwpc(i) = 0
798  80 CONTINUE
799  mwps(1) = 0
800  DO 100 i = 2, 6
801  mwps(i) = 1
802  100 CONTINUE
803  DO 120 i = 7, 11
804  mwps(i) = -1
805  120 CONTINUE
806  mwpinx(1) = 1
807  mwpinx(2) = 1
808  mwpinx(3) = 1
809  mwpinx(4) = -1
810  mwpinx(5) = 1
811  mwpinx(6) = -1
812  mwpinx(7) = 1
813  mwpinx(8) = 1
814  mwpinx(9) = -1
815  mwpinx(10) = 1
816  mwpinx(11) = -1
817  mwpiny(1) = 1
818  mwpiny(2) = 1
819  mwpiny(3) = -1
820  mwpiny(4) = -1
821  mwpiny(5) = 2
822  mwpiny(6) = 1
823  mwpiny(7) = 1
824  mwpiny(8) = -1
825  mwpiny(9) = -1
826  mwpiny(10) = 2
827  mwpiny(11) = 1
828  DO 140 i = 1, 11
829  mwpn(i) = 5
830  140 CONTINUE
831  mwpn(5) = 3
832  mwpn(10) = 3
833  DO 160 i = 1, 5
834  mwpx(i) = i
835  mwpy(i) = i
836  mwptx(1,i) = i
837  mwpty(1,i) = i
838  mwptx(2,i) = i
839  mwpty(2,i) = -i
840  mwptx(3,i) = 6 - i
841  mwpty(3,i) = i - 6
842  mwptx(4,i) = i
843  mwpty(4,i) = -i
844  mwptx(6,i) = 6 - i
845  mwpty(6,i) = i - 6
846  mwptx(7,i) = -i
847  mwpty(7,i) = i
848  mwptx(8,i) = i - 6
849  mwpty(8,i) = 6 - i
850  mwptx(9,i) = -i
851  mwpty(9,i) = i
852  mwptx(11,i) = i - 6
853  mwpty(11,i) = 6 - i
854  160 CONTINUE
855  mwptx(5,1) = 1
856  mwptx(5,2) = 3
857  mwptx(5,3) = 5
858  mwptx(5,4) = 4
859  mwptx(5,5) = 5
860  mwpty(5,1) = -1
861  mwpty(5,2) = 2
862  mwpty(5,3) = -2
863  mwpty(5,4) = 4
864  mwpty(5,5) = -3
865  mwptx(10,1) = -1
866  mwptx(10,2) = -3
867  mwptx(10,3) = -5
868  mwptx(10,4) = 4
869  mwptx(10,5) = 5
870  mwpty(10,1) = 1
871  mwpty(10,2) = 2
872  mwpty(10,3) = 2
873  mwpty(10,4) = 4
874  mwpty(10,5) = 3
875  DO 200 i = 1, 11
876  incx = mwpinx(i)
877  incy = mwpiny(i)
878  DO 180 k = 1, 5
879  copyx(k) = mwpx(k)
880  copyy(k) = mwpy(k)
881  mwpstx(k) = mwptx(i,k)
882  mwpsty(k) = mwpty(i,k)
883  180 CONTINUE
884  CALL srot(mwpn(i),copyx,incx,copyy,incy,mwpc(i),mwps(i))
885  CALL stest(5,copyx,mwpstx,mwpstx,sfac)
886  CALL stest(5,copyy,mwpsty,mwpsty,sfac)
887  200 CONTINUE
888  RETURN
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT
Definition: srot.f:53

Here is the call graph for this function:

subroutine header ( )

Definition at line 96 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 *
124 99999 FORMAT (/' Test of subprogram number',i3,12x,a6)
subroutine itest1 ( integer  ICOMP,
integer  ITRUE 
)

Definition at line 982 of file sblat1.f.

982 * ********************************* ITEST1 *************************
983 *
984 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
985 * EQUALITY.
986 * C. L. LAWSON, JPL, 1974 DEC 10
987 *
988 * .. Parameters ..
989  INTEGER nout
990  parameter(nout=6)
991 * .. Scalar Arguments ..
992  INTEGER icomp, itrue
993 * .. Scalars in Common ..
994  INTEGER icase, incx, incy, n
995  LOGICAL pass
996 * .. Local Scalars ..
997  INTEGER id
998 * .. Common blocks ..
999  COMMON /combla/icase, n, incx, incy, pass
1000 * .. Executable Statements ..
1001 *
1002  IF (icomp.EQ.itrue) GO TO 40
1003 *
1004 * HERE ICOMP IS NOT EQUAL TO ITRUE.
1005 *
1006  IF ( .NOT. pass) GO TO 20
1007 * PRINT FAIL MESSAGE AND HEADER.
1008  pass = .false.
1009  WRITE (nout,99999)
1010  WRITE (nout,99998)
1011  20 id = icomp - itrue
1012  WRITE (nout,99997) icase, n, incx, incy, icomp, itrue, id
1013  40 CONTINUE
1014  RETURN
1015 *
1016 99999 FORMAT (' FAIL')
1017 99998 FORMAT (/' CASE N INCX INCY ',
1018  + ' COMP TRUE DIFFERENCE',
1019  + /1x)
1020 99997 FORMAT (1x,i4,i3,2i5,2i36,i12)
program sblat1 ( )

SBLAT1

Purpose:
    Test program for the REAL Level 1 BLAS.

    Based upon the original BLAS test routine together with:
    F06EAF Example Program Text
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
April 2012

Definition at line 38 of file sblat1.f.

Here is the call graph for this function:

real function sdiff ( real  SA,
real  SB 
)

Definition at line 972 of file sblat1.f.

972 * ********************************* SDIFF **************************
973 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
974 *
975 * .. Scalar Arguments ..
976  REAL sa, sb
977 * .. Executable Statements ..
978  sdiff = sa - sb
979  RETURN
real function sdiff(SA, SB)
Definition: cblat1.f:645

Here is the call graph for this function:

subroutine stest ( integer  LEN,
real, dimension(len)  SCOMP,
real, dimension(len)  STRUE,
real, dimension(len)  SSIZE,
real  SFAC 
)

Definition at line 891 of file sblat1.f.

891 * ********************************* STEST **************************
892 *
893 * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
894 * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
895 * NEGLIGIBLE.
896 *
897 * C. L. LAWSON, JPL, 1974 DEC 10
898 *
899 * .. Parameters ..
900  INTEGER nout
901  REAL zero
902  parameter(nout=6, zero=0.0e0)
903 * .. Scalar Arguments ..
904  REAL sfac
905  INTEGER len
906 * .. Array Arguments ..
907  REAL scomp(len), ssize(len), strue(len)
908 * .. Scalars in Common ..
909  INTEGER icase, incx, incy, n
910  LOGICAL pass
911 * .. Local Scalars ..
912  REAL sd
913  INTEGER i
914 * .. External Functions ..
915  REAL sdiff
916  EXTERNAL sdiff
917 * .. Intrinsic Functions ..
918  INTRINSIC abs
919 * .. Common blocks ..
920  COMMON /combla/icase, n, incx, incy, pass
921 * .. Executable Statements ..
922 *
923  DO 40 i = 1, len
924  sd = scomp(i) - strue(i)
925  IF (abs(sfac*sd) .LE. abs(ssize(i))*epsilon(zero))
926  + GO TO 40
927 *
928 * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
929 *
930  IF ( .NOT. pass) GO TO 20
931 * PRINT FAIL MESSAGE AND HEADER.
932  pass = .false.
933  WRITE (nout,99999)
934  WRITE (nout,99998)
935  20 WRITE (nout,99997) icase, n, incx, incy, i, scomp(i),
936  + strue(i), sd, ssize(i)
937  40 CONTINUE
938  RETURN
939 *
940 99999 FORMAT (' FAIL')
941 99998 FORMAT (/' CASE N INCX INCY I ',
942  + ' COMP(I) TRUE(I) DIFFERENCE',
943  + ' SIZE(I)',/1x)
944 99997 FORMAT (1x,i4,i3,2i5,i3,2e36.8,2e12.4)
real function sdiff(SA, SB)
Definition: cblat1.f:645
subroutine stest1 ( real  SCOMP1,
real  STRUE1,
real, dimension(*)  SSIZE,
real  SFAC 
)

Definition at line 947 of file sblat1.f.

947 * ************************* STEST1 *****************************
948 *
949 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
950 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
951 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
952 *
953 * C.L. LAWSON, JPL, 1978 DEC 6
954 *
955 * .. Scalar Arguments ..
956  REAL scomp1, sfac, strue1
957 * .. Array Arguments ..
958  REAL ssize(*)
959 * .. Local Arrays ..
960  REAL scomp(1), strue(1)
961 * .. External Subroutines ..
962  EXTERNAL stest
963 * .. Executable Statements ..
964 *
965  scomp(1) = scomp1
966  strue(1) = strue1
967  CALL stest(1,scomp,strue,ssize,sfac)
968 *
969  RETURN
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564

Here is the call graph for this function: