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

Go to the source code of this file.

Functions/Subroutines

program dblat1
 DBLAT1 More...
 
subroutine header
 
subroutine check0 (SFAC)
 
subroutine check1 (SFAC)
 
subroutine check2 (SFAC)
 
subroutine check3 (SFAC)
 
subroutine stest (LEN, SCOMP, STRUE, SSIZE, SFAC)
 
subroutine testdsdot (SCOMP, STRUE, SSIZE, SFAC)
 
subroutine stest1 (SCOMP1, STRUE1, SSIZE, SFAC)
 
double precision function sdiff (SA, SB)
 
subroutine itest1 (ICOMP, ITRUE)
 

Function/Subroutine Documentation

subroutine check0 ( double precision  SFAC)

Definition at line 127 of file dblat1.f.

127 * .. Parameters ..
128  INTEGER nout
129  parameter(nout=6)
130 * .. Scalar Arguments ..
131  DOUBLE PRECISION sfac
132 * .. Scalars in Common ..
133  INTEGER icase, incx, incy, n
134  LOGICAL pass
135 * .. Local Scalars ..
136  DOUBLE PRECISION sa, sb, sc, ss, d12
137  INTEGER i, k
138 * .. Local Arrays ..
139  DOUBLE PRECISION 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 drotg, drotmg, stest1
143 * .. Common blocks ..
144  COMMON /combla/icase, n, incx, incy, pass
145 * .. Data statements ..
146  DATA da1/0.3d0, 0.4d0, -0.3d0, -0.4d0, -0.3d0, 0.0d0,
147  + 0.0d0, 1.0d0/
148  DATA db1/0.4d0, 0.3d0, 0.4d0, 0.3d0, -0.4d0, 0.0d0,
149  + 1.0d0, 0.0d0/
150  DATA dc1/0.6d0, 0.8d0, -0.6d0, 0.8d0, 0.6d0, 1.0d0,
151  + 0.0d0, 1.0d0/
152  DATA ds1/0.8d0, 0.6d0, 0.8d0, -0.6d0, 0.8d0, 0.0d0,
153  + 1.0d0, 0.0d0/
154  DATA datrue/0.5d0, 0.5d0, 0.5d0, -0.5d0, -0.5d0,
155  + 0.0d0, 1.0d0, 1.0d0/
156  DATA dbtrue/0.0d0, 0.6d0, 0.0d0, -0.6d0, 0.0d0,
157  + 0.0d0, 1.0d0, 0.0d0/
158 * INPUT FOR MODIFIED GIVENS
159  DATA dab/ .1d0,.3d0,1.2d0,.2d0,
160  a .7d0, .2d0, .6d0, 4.2d0,
161  b 0.d0,0.d0,0.d0,0.d0,
162  c 4.d0, -1.d0, 2.d0, 4.d0,
163  d 6.d-10, 2.d-2, 1.d5, 10.d0,
164  e 4.d10, 2.d-2, 1.d-5, 10.d0,
165  f 2.d-10, 4.d-2, 1.d5, 10.d0,
166  g 2.d10, 4.d-2, 1.d-5, 10.d0,
167  h 4.d0, -2.d0, 8.d0, 4.d0 /
168 * TRUE RESULTS FOR MODIFIED GIVENS
169  DATA dtrue/0.d0,0.d0, 1.3d0, .2d0, 0.d0,0.d0,0.d0, .5d0, 0.d0,
170  a 0.d0,0.d0, 4.5d0, 4.2d0, 1.d0, .5d0, 0.d0,0.d0,0.d0,
171  b 0.d0,0.d0,0.d0,0.d0, -2.d0, 0.d0,0.d0,0.d0,0.d0,
172  c 0.d0,0.d0,0.d0, 4.d0, -1.d0, 0.d0,0.d0,0.d0,0.d0,
173  d 0.d0, 15.d-3, 0.d0, 10.d0, -1.d0, 0.d0, -1.d-4,
174  e 0.d0, 1.d0,
175  f 0.d0,0.d0, 6144.d-5, 10.d0, -1.d0, 4096.d0, -1.d6,
176  g 0.d0, 1.d0,
177  h 0.d0,0.d0,15.d0,10.d0,-1.d0, 5.d-5, 0.d0,1.d0,0.d0,
178  i 0.d0,0.d0, 15.d0, 10.d0, -1. d0, 5.d5, -4096.d0,
179  j 1.d0, 4096.d-6,
180  k 0.d0,0.d0, 7.d0, 4.d0, 0.d0,0.d0, -.5d0, -.25d0, 0.d0/
181 * 4096 = 2 ** 12
182  DATA d12 /4096.d0/
183  dtrue(1,1) = 12.d0 / 130.d0
184  dtrue(2,1) = 36.d0 / 130.d0
185  dtrue(7,1) = -1.d0 / 6.d0
186  dtrue(1,2) = 14.d0 / 75.d0
187  dtrue(2,2) = 49.d0 / 75.d0
188  dtrue(9,2) = 1.d0 / 7.d0
189  dtrue(1,5) = 45.d-11 * (d12 * d12)
190  dtrue(3,5) = 4.d5 / (3.d0 * d12)
191  dtrue(6,5) = 1.d0 / d12
192  dtrue(8,5) = 1.d4 / (3.d0 * d12)
193  dtrue(1,6) = 4.d10 / (1.5d0 * d12 * d12)
194  dtrue(2,6) = 2.d-2 / 1.5d0
195  dtrue(8,6) = 5.d-7 * d12
196  dtrue(1,7) = 4.d0 / 150.d0
197  dtrue(2,7) = (2.d-10 / 1.5d0) * (d12 * d12)
198  dtrue(7,7) = -dtrue(6,5)
199  dtrue(9,7) = 1.d4 / d12
200  dtrue(1,8) = dtrue(1,7)
201  dtrue(2,8) = 2.d10 / (1.5d0 * d12 * d12)
202  dtrue(1,9) = 32.d0 / 7.d0
203  dtrue(2,9) = -16.d0 / 7.d0
204 * .. Executable Statements ..
205 *
206 * Compute true values which cannot be prestored
207 * in decimal notation
208 *
209  dbtrue(1) = 1.0d0/0.6d0
210  dbtrue(3) = -1.0d0/0.6d0
211  dbtrue(5) = 1.0d0/0.6d0
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 * .. DROTG ..
218  IF (k.GT.8) GO TO 40
219  sa = da1(k)
220  sb = db1(k)
221  CALL drotg(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 * .. DROTMG ..
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 drotmg(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 drotg(DA, DB, C, S)
DROTG
Definition: drotg.f:48
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:620
subroutine drotmg(DD1, DD2, DX1, DY1, DPARAM)
DROTMG
Definition: drotmg.f:92

Here is the call graph for this function:

Here is the caller graph for this function:

subroutine check1 ( double precision  SFAC)

Definition at line 243 of file dblat1.f.

243 * .. Parameters ..
244  INTEGER nout
245  parameter(nout=6)
246 * .. Scalar Arguments ..
247  DOUBLE PRECISION 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  DOUBLE PRECISION 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  DOUBLE PRECISION dasum, dnrm2
259  INTEGER idamax
260  EXTERNAL dasum, dnrm2, idamax
261 * .. External Subroutines ..
262  EXTERNAL itest1, dscal, 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.3d0, -1.0d0, 0.0d0, 1.0d0, 0.3d0, 0.3d0,
269  + 0.3d0, 0.3d0, 0.3d0, 0.3d0/
270  DATA dv/0.1d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0,
271  + 2.0d0, 2.0d0, 0.3d0, 3.0d0, 3.0d0, 3.0d0, 3.0d0,
272  + 3.0d0, 3.0d0, 3.0d0, 0.3d0, -0.4d0, 4.0d0,
273  + 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 0.2d0,
274  + -0.6d0, 0.3d0, 5.0d0, 5.0d0, 5.0d0, 5.0d0,
275  + 5.0d0, 0.1d0, -0.3d0, 0.5d0, -0.1d0, 6.0d0,
276  + 6.0d0, 6.0d0, 6.0d0, 0.1d0, 8.0d0, 8.0d0, 8.0d0,
277  + 8.0d0, 8.0d0, 8.0d0, 8.0d0, 0.3d0, 9.0d0, 9.0d0,
278  + 9.0d0, 9.0d0, 9.0d0, 9.0d0, 9.0d0, 0.3d0, 2.0d0,
279  + -0.4d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0,
280  + 0.2d0, 3.0d0, -0.6d0, 5.0d0, 0.3d0, 2.0d0,
281  + 2.0d0, 2.0d0, 0.1d0, 4.0d0, -0.3d0, 6.0d0,
282  + -0.5d0, 7.0d0, -0.1d0, 3.0d0/
283  DATA dtrue1/0.0d0, 0.3d0, 0.5d0, 0.7d0, 0.6d0/
284  DATA dtrue3/0.0d0, 0.3d0, 0.7d0, 1.1d0, 1.0d0/
285  DATA dtrue5/0.10d0, 2.0d0, 2.0d0, 2.0d0, 2.0d0,
286  + 2.0d0, 2.0d0, 2.0d0, -0.3d0, 3.0d0, 3.0d0,
287  + 3.0d0, 3.0d0, 3.0d0, 3.0d0, 3.0d0, 0.0d0, 0.0d0,
288  + 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0,
289  + 0.20d0, -0.60d0, 0.30d0, 5.0d0, 5.0d0, 5.0d0,
290  + 5.0d0, 5.0d0, 0.03d0, -0.09d0, 0.15d0, -0.03d0,
291  + 6.0d0, 6.0d0, 6.0d0, 6.0d0, 0.10d0, 8.0d0,
292  + 8.0d0, 8.0d0, 8.0d0, 8.0d0, 8.0d0, 8.0d0,
293  + 0.09d0, 9.0d0, 9.0d0, 9.0d0, 9.0d0, 9.0d0,
294  + 9.0d0, 9.0d0, 0.09d0, 2.0d0, -0.12d0, 2.0d0,
295  + 2.0d0, 2.0d0, 2.0d0, 2.0d0, 0.06d0, 3.0d0,
296  + -0.18d0, 5.0d0, 0.09d0, 2.0d0, 2.0d0, 2.0d0,
297  + 0.03d0, 4.0d0, -0.09d0, 6.0d0, -0.15d0, 7.0d0,
298  + -0.03d0, 3.0d0/
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 * .. DNRM2 ..
312  stemp(1) = dtrue1(np1)
313  CALL stest1(dnrm2(n,sx,incx),stemp(1),stemp,sfac)
314  ELSE IF (icase.EQ.8) THEN
315 * .. DASUM ..
316  stemp(1) = dtrue3(np1)
317  CALL stest1(dasum(n,sx,incx),stemp(1),stemp,sfac)
318  ELSE IF (icase.EQ.9) THEN
319 * .. DSCAL ..
320  CALL dscal(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 * .. IDAMAX ..
327  CALL itest1(idamax(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
subroutine itest1(ICOMP, ITRUE)
Definition: cblat1.f:686
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564
subroutine dscal(N, DA, DX, INCX)
DSCAL
Definition: dscal.f:55
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:620
integer function idamax(N, DX, INCX)
IDAMAX
Definition: idamax.f:53
double precision function dnrm2(N, X, INCX)
DNRM2
Definition: dnrm2.f:56
double precision function dasum(N, DX, INCX)
DASUM
Definition: dasum.f:53

Here is the call graph for this function:

subroutine check2 ( double precision  SFAC)

Definition at line 337 of file dblat1.f.

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

Here is the call graph for this function:

subroutine check3 ( double precision  SFAC)

Definition at line 681 of file dblat1.f.

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

Here is the call graph for this function:

Here is the caller graph for this function:

program dblat1 ( )

DBLAT1

Purpose:
    Test program for the DOUBLE PRECISION 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 dblat1.f.

Here is the call graph for this function:

subroutine header ( )

Definition at line 96 of file dblat1.f.

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

Definition at line 1026 of file dblat1.f.

1026 * ********************************* ITEST1 *************************
1027 *
1028 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
1029 * EQUALITY.
1030 * C. L. LAWSON, JPL, 1974 DEC 10
1031 *
1032 * .. Parameters ..
1033  INTEGER nout
1034  parameter(nout=6)
1035 * .. Scalar Arguments ..
1036  INTEGER icomp, itrue
1037 * .. Scalars in Common ..
1038  INTEGER icase, incx, incy, n
1039  LOGICAL pass
1040 * .. Local Scalars ..
1041  INTEGER id
1042 * .. Common blocks ..
1043  COMMON /combla/icase, n, incx, incy, pass
1044 * .. Executable Statements ..
1045 *
1046  IF (icomp.EQ.itrue) GO TO 40
1047 *
1048 * HERE ICOMP IS NOT EQUAL TO ITRUE.
1049 *
1050  IF ( .NOT. pass) GO TO 20
1051 * PRINT FAIL MESSAGE AND HEADER.
1052  pass = .false.
1053  WRITE (nout,99999)
1054  WRITE (nout,99998)
1055  20 id = icomp - itrue
1056  WRITE (nout,99997) icase, n, incx, incy, icomp, itrue, id
1057  40 CONTINUE
1058  RETURN
1059 *
1060 99999 FORMAT (' FAIL')
1061 99998 FORMAT (/' CASE N INCX INCY ',
1062  + ' COMP TRUE DIFFERENCE',
1063  + /1x)
1064 99997 FORMAT (1x,i4,i3,2i5,2i36,i12)
double precision function sdiff ( double precision  SA,
double precision  SB 
)

Definition at line 1016 of file dblat1.f.

1016 * ********************************* SDIFF **************************
1017 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
1018 *
1019 * .. Scalar Arguments ..
1020  DOUBLE PRECISION sa, sb
1021 * .. Executable Statements ..
1022  sdiff = sa - sb
1023  RETURN
real function sdiff(SA, SB)
Definition: cblat1.f:645

Here is the call graph for this function:

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

Definition at line 887 of file dblat1.f.

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

Definition at line 991 of file dblat1.f.

991 * ************************* STEST1 *****************************
992 *
993 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
994 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
995 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
996 *
997 * C.L. LAWSON, JPL, 1978 DEC 6
998 *
999 * .. Scalar Arguments ..
1000  DOUBLE PRECISION scomp1, sfac, strue1
1001 * .. Array Arguments ..
1002  DOUBLE PRECISION ssize(*)
1003 * .. Local Arrays ..
1004  DOUBLE PRECISION scomp(1), strue(1)
1005 * .. External Subroutines ..
1006  EXTERNAL stest
1007 * .. Executable Statements ..
1008 *
1009  scomp(1) = scomp1
1010  strue(1) = strue1
1011  CALL stest(1,scomp,strue,ssize,sfac)
1012 *
1013  RETURN
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564

Here is the call graph for this function:

subroutine testdsdot ( real  SCOMP,
real  STRUE,
real  SSIZE,
real  SFAC 
)

Definition at line 943 of file dblat1.f.

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

Here is the caller graph for this function: