LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
sblat1.f
Go to the documentation of this file.
1 *> \brief \b SBLAT1
2 *
3 * =========== DOCUMENTATION ===========
4 *
5 * Online html documentation available at
6 * http://www.netlib.org/lapack/explore-html/
7 *
8 * Definition:
9 * ===========
10 *
11 * PROGRAM SBLAT1
12 *
13 *
14 *> \par Purpose:
15 * =============
16 *>
17 *> \verbatim
18 *>
19 *> Test program for the REAL Level 1 BLAS.
20 *>
21 *> Based upon the original BLAS test routine together with:
22 *> F06EAF Example Program Text
23 *> \endverbatim
24 *
25 * Authors:
26 * ========
27 *
28 *> \author Univ. of Tennessee
29 *> \author Univ. of California Berkeley
30 *> \author Univ. of Colorado Denver
31 *> \author NAG Ltd.
32 *
33 *> \date April 2012
34 *
35 *> \ingroup single_blas_testing
36 *
37 * =====================================================================
38  PROGRAM sblat1
39 *
40 * -- Reference BLAS test routine (version 3.4.1) --
41 * -- Reference BLAS is a software package provided by Univ. of Tennessee, --
42 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
43 * April 2012
44 *
45 * =====================================================================
46 *
47 * .. Parameters ..
48  INTEGER nout
49  parameter(nout=6)
50 * .. Scalars in Common ..
51  INTEGER icase, incx, incy, n
52  LOGICAL pass
53 * .. Local Scalars ..
54  REAL sfac
55  INTEGER ic
56 * .. External Subroutines ..
57  EXTERNAL check0, check1, check2, check3, header
58 * .. Common blocks ..
59  common /combla/icase, n, incx, incy, pass
60 * .. Data statements ..
61  DATA sfac/9.765625e-4/
62 * .. Executable Statements ..
63  WRITE (nout,99999)
64  DO 20 ic = 1, 13
65  icase = ic
66  CALL header
67 *
68 * .. Initialize PASS, INCX, and INCY for a new case. ..
69 * .. the value 9999 for INCX or INCY will appear in the ..
70 * .. detailed output, if any, for cases that do not involve ..
71 * .. these parameters ..
72 *
73  pass = .true.
74  incx = 9999
75  incy = 9999
76  IF (icase.EQ.3 .OR. icase.EQ.11) THEN
77  CALL check0(sfac)
78  ELSE IF (icase.EQ.7 .OR. icase.EQ.8 .OR. icase.EQ.9 .OR.
79  + icase.EQ.10) THEN
80  CALL check1(sfac)
81  ELSE IF (icase.EQ.1 .OR. icase.EQ.2 .OR. icase.EQ.5 .OR.
82  + icase.EQ.6 .OR. icase.EQ.12 .OR. icase.EQ.13) THEN
83  CALL check2(sfac)
84  ELSE IF (icase.EQ.4) THEN
85  CALL check3(sfac)
86  END IF
87 * -- Print
88  IF (pass) WRITE (nout,99998)
89  20 continue
90  stop
91 *
92 99999 format(' Real BLAS Test Program Results',/1x)
93 99998 format(' ----- PASS -----')
94  END
95  SUBROUTINE header
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)
125  END
126  SUBROUTINE check0(SFAC)
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
241  END
242  SUBROUTINE check1(SFAC)
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
335  END
336  SUBROUTINE check2(SFAC)
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
683  END
684  SUBROUTINE check3(SFAC)
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
889  END
890  SUBROUTINE stest(LEN,SCOMP,STRUE,SSIZE,SFAC)
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)
945  END
946  SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
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
970  END
971  REAL FUNCTION sdiff(SA,SB)
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
980  END
981  SUBROUTINE itest1(ICOMP,ITRUE)
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)
1021  END