LAPACK  3.6.1
LAPACK: Linear Algebra PACKage
c_sblat1.f
Go to the documentation of this file.
1  PROGRAM scblat1
2 * Test program for the REAL Level 1 CBLAS.
3 * Based upon the original CBLAS test routine together with:
4 * F06EAF Example Program Text
5 * .. Parameters ..
6  INTEGER NOUT
7  parameter (nout=6)
8 * .. Scalars in Common ..
9  INTEGER ICASE, INCX, INCY, MODE, N
10  LOGICAL PASS
11 * .. Local Scalars ..
12  REAL SFAC
13  INTEGER IC
14 * .. External Subroutines ..
15  EXTERNAL check0, check1, check2, check3, header
16 * .. Common blocks ..
17  COMMON /combla/icase, n, incx, incy, mode, pass
18 * .. Data statements ..
19  DATA sfac/9.765625e-4/
20 * .. Executable Statements ..
21  WRITE (nout,99999)
22  DO 20 ic = 1, 10
23  icase = ic
24  CALL header
25 *
26 * .. Initialize PASS, INCX, INCY, and MODE for a new case. ..
27 * .. the value 9999 for INCX, INCY or MODE will appear in the ..
28 * .. detailed output, if any, for cases that do not involve ..
29 * .. these parameters ..
30 *
31  pass = .true.
32  incx = 9999
33  incy = 9999
34  mode = 9999
35  IF (icase.EQ.3) THEN
36  CALL check0(sfac)
37  ELSE IF (icase.EQ.7 .OR. icase.EQ.8 .OR. icase.EQ.9 .OR.
38  + icase.EQ.10) THEN
39  CALL check1(sfac)
40  ELSE IF (icase.EQ.1 .OR. icase.EQ.2 .OR. icase.EQ.5 .OR.
41  + icase.EQ.6) THEN
42  CALL check2(sfac)
43  ELSE IF (icase.EQ.4) THEN
44  CALL check3(sfac)
45  END IF
46 * -- Print
47  IF (pass) WRITE (nout,99998)
48  20 CONTINUE
49  stop
50 *
51 99999 FORMAT (' Real CBLAS Test Program Results',/1x)
52 99998 FORMAT (' ----- PASS -----')
53  END
54  SUBROUTINE header
55 * .. Parameters ..
56  INTEGER NOUT
57  parameter (nout=6)
58 * .. Scalars in Common ..
59  INTEGER ICASE, INCX, INCY, MODE, N
60  LOGICAL PASS
61 * .. Local Arrays ..
62  CHARACTER*15 L(10)
63 * .. Common blocks ..
64  COMMON /combla/icase, n, incx, incy, mode, pass
65 * .. Data statements ..
66  DATA l(1)/'CBLAS_SDOT '/
67  DATA l(2)/'CBLAS_SAXPY '/
68  DATA l(3)/'CBLAS_SROTG '/
69  DATA l(4)/'CBLAS_SROT '/
70  DATA l(5)/'CBLAS_SCOPY '/
71  DATA l(6)/'CBLAS_SSWAP '/
72  DATA l(7)/'CBLAS_SNRM2 '/
73  DATA l(8)/'CBLAS_SASUM '/
74  DATA l(9)/'CBLAS_SSCAL '/
75  DATA l(10)/'CBLAS_ISAMAX'/
76 * .. Executable Statements ..
77  WRITE (nout,99999) icase, l(icase)
78  RETURN
79 *
80 99999 FORMAT (/' Test of subprogram number',i3,9x,a15)
81  END
82  SUBROUTINE check0(SFAC)
83 * .. Parameters ..
84  INTEGER NOUT
85  parameter (nout=6)
86 * .. Scalar Arguments ..
87  REAL SFAC
88 * .. Scalars in Common ..
89  INTEGER ICASE, INCX, INCY, MODE, N
90  LOGICAL PASS
91 * .. Local Scalars ..
92  REAL SA, SB, SC, SS
93  INTEGER K
94 * .. Local Arrays ..
95  REAL DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
96  + ds1(8)
97 * .. External Subroutines ..
98  EXTERNAL srotgtest, stest1
99 * .. Common blocks ..
100  COMMON /combla/icase, n, incx, incy, mode, pass
101 * .. Data statements ..
102  DATA da1/0.3e0, 0.4e0, -0.3e0, -0.4e0, -0.3e0, 0.0e0,
103  + 0.0e0, 1.0e0/
104  DATA db1/0.4e0, 0.3e0, 0.4e0, 0.3e0, -0.4e0, 0.0e0,
105  + 1.0e0, 0.0e0/
106  DATA dc1/0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.6e0, 1.0e0,
107  + 0.0e0, 1.0e0/
108  DATA ds1/0.8e0, 0.6e0, 0.8e0, -0.6e0, 0.8e0, 0.0e0,
109  + 1.0e0, 0.0e0/
110  DATA datrue/0.5e0, 0.5e0, 0.5e0, -0.5e0, -0.5e0,
111  + 0.0e0, 1.0e0, 1.0e0/
112  DATA dbtrue/0.0e0, 0.6e0, 0.0e0, -0.6e0, 0.0e0,
113  + 0.0e0, 1.0e0, 0.0e0/
114 * .. Executable Statements ..
115 *
116 * Compute true values which cannot be prestored
117 * in decimal notation
118 *
119  dbtrue(1) = 1.0e0/0.6e0
120  dbtrue(3) = -1.0e0/0.6e0
121  dbtrue(5) = 1.0e0/0.6e0
122 *
123  DO 20 k = 1, 8
124 * .. Set N=K for identification in output if any ..
125  n = k
126  IF (icase.EQ.3) THEN
127 * .. SROTGTEST ..
128  IF (k.GT.8) GO TO 40
129  sa = da1(k)
130  sb = db1(k)
131  CALL srotgtest(sa,sb,sc,ss)
132  CALL stest1(sa,datrue(k),datrue(k),sfac)
133  CALL stest1(sb,dbtrue(k),dbtrue(k),sfac)
134  CALL stest1(sc,dc1(k),dc1(k),sfac)
135  CALL stest1(ss,ds1(k),ds1(k),sfac)
136  ELSE
137  WRITE (nout,*) ' Shouldn''t be here in CHECK0'
138  stop
139  END IF
140  20 CONTINUE
141  40 RETURN
142  END
143  SUBROUTINE check1(SFAC)
144 * .. Parameters ..
145  INTEGER NOUT
146  parameter (nout=6)
147 * .. Scalar Arguments ..
148  REAL SFAC
149 * .. Scalars in Common ..
150  INTEGER ICASE, INCX, INCY, MODE, N
151  LOGICAL PASS
152 * .. Local Scalars ..
153  INTEGER I, LEN, NP1
154 * .. Local Arrays ..
155  REAL DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
156  + sa(10), stemp(1), strue(8), sx(8)
157  INTEGER ITRUE2(5)
158 * .. External Functions ..
159  REAL SASUMTEST, SNRM2TEST
160  INTEGER ISAMAXTEST
161  EXTERNAL sasumtest, snrm2test, isamaxtest
162 * .. External Subroutines ..
163  EXTERNAL itest1, sscaltest, stest, stest1
164 * .. Intrinsic Functions ..
165  INTRINSIC max
166 * .. Common blocks ..
167  COMMON /combla/icase, n, incx, incy, mode, pass
168 * .. Data statements ..
169  DATA sa/0.3e0, -1.0e0, 0.0e0, 1.0e0, 0.3e0, 0.3e0,
170  + 0.3e0, 0.3e0, 0.3e0, 0.3e0/
171  DATA dv/0.1e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
172  + 2.0e0, 2.0e0, 0.3e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0,
173  + 3.0e0, 3.0e0, 3.0e0, 0.3e0, -0.4e0, 4.0e0,
174  + 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 0.2e0,
175  + -0.6e0, 0.3e0, 5.0e0, 5.0e0, 5.0e0, 5.0e0,
176  + 5.0e0, 0.1e0, -0.3e0, 0.5e0, -0.1e0, 6.0e0,
177  + 6.0e0, 6.0e0, 6.0e0, 0.1e0, 8.0e0, 8.0e0, 8.0e0,
178  + 8.0e0, 8.0e0, 8.0e0, 8.0e0, 0.3e0, 9.0e0, 9.0e0,
179  + 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 0.3e0, 2.0e0,
180  + -0.4e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
181  + 0.2e0, 3.0e0, -0.6e0, 5.0e0, 0.3e0, 2.0e0,
182  + 2.0e0, 2.0e0, 0.1e0, 4.0e0, -0.3e0, 6.0e0,
183  + -0.5e0, 7.0e0, -0.1e0, 3.0e0/
184  DATA dtrue1/0.0e0, 0.3e0, 0.5e0, 0.7e0, 0.6e0/
185  DATA dtrue3/0.0e0, 0.3e0, 0.7e0, 1.1e0, 1.0e0/
186  DATA dtrue5/0.10e0, 2.0e0, 2.0e0, 2.0e0, 2.0e0,
187  + 2.0e0, 2.0e0, 2.0e0, -0.3e0, 3.0e0, 3.0e0,
188  + 3.0e0, 3.0e0, 3.0e0, 3.0e0, 3.0e0, 0.0e0, 0.0e0,
189  + 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0, 4.0e0,
190  + 0.20e0, -0.60e0, 0.30e0, 5.0e0, 5.0e0, 5.0e0,
191  + 5.0e0, 5.0e0, 0.03e0, -0.09e0, 0.15e0, -0.03e0,
192  + 6.0e0, 6.0e0, 6.0e0, 6.0e0, 0.10e0, 8.0e0,
193  + 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0, 8.0e0,
194  + 0.09e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0, 9.0e0,
195  + 9.0e0, 9.0e0, 0.09e0, 2.0e0, -0.12e0, 2.0e0,
196  + 2.0e0, 2.0e0, 2.0e0, 2.0e0, 0.06e0, 3.0e0,
197  + -0.18e0, 5.0e0, 0.09e0, 2.0e0, 2.0e0, 2.0e0,
198  + 0.03e0, 4.0e0, -0.09e0, 6.0e0, -0.15e0, 7.0e0,
199  + -0.03e0, 3.0e0/
200  DATA itrue2/0, 1, 2, 2, 3/
201 * .. Executable Statements ..
202  DO 80 incx = 1, 2
203  DO 60 np1 = 1, 5
204  n = np1 - 1
205  len = 2*max(n,1)
206 * .. Set vector arguments ..
207  DO 20 i = 1, len
208  sx(i) = dv(i,np1,incx)
209  20 CONTINUE
210 *
211  IF (icase.EQ.7) THEN
212 * .. SNRM2TEST ..
213  stemp(1) = dtrue1(np1)
214  CALL stest1(snrm2test(n,sx,incx),stemp,stemp,sfac)
215  ELSE IF (icase.EQ.8) THEN
216 * .. SASUMTEST ..
217  stemp(1) = dtrue3(np1)
218  CALL stest1(sasumtest(n,sx,incx),stemp,stemp,sfac)
219  ELSE IF (icase.EQ.9) THEN
220 * .. SSCALTEST ..
221  CALL sscaltest(n,sa((incx-1)*5+np1),sx,incx)
222  DO 40 i = 1, len
223  strue(i) = dtrue5(i,np1,incx)
224  40 CONTINUE
225  CALL stest(len,sx,strue,strue,sfac)
226  ELSE IF (icase.EQ.10) THEN
227 * .. ISAMAXTEST ..
228  CALL itest1(isamaxtest(n,sx,incx),itrue2(np1))
229  ELSE
230  WRITE (nout,*) ' Shouldn''t be here in CHECK1'
231  stop
232  END IF
233  60 CONTINUE
234  80 CONTINUE
235  RETURN
236  END
237  SUBROUTINE check2(SFAC)
238 * .. Parameters ..
239  INTEGER NOUT
240  parameter (nout=6)
241 * .. Scalar Arguments ..
242  REAL SFAC
243 * .. Scalars in Common ..
244  INTEGER ICASE, INCX, INCY, MODE, N
245  LOGICAL PASS
246 * .. Local Scalars ..
247  REAL SA
248  INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
249 * .. Local Arrays ..
250  REAL DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
251  + dt8(7,4,4), dx1(7),
252  + dy1(7), ssize1(4), ssize2(14,2), stx(7), sty(7),
253  + sx(7), sy(7)
254  INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
255 * .. External Functions ..
256  REAL SDOTTEST
257  EXTERNAL sdottest
258 * .. External Subroutines ..
259  EXTERNAL saxpytest, scopytest, sswaptest, stest, stest1
260 * .. Intrinsic Functions ..
261  INTRINSIC abs, min
262 * .. Common blocks ..
263  COMMON /combla/icase, n, incx, incy, mode, pass
264 * .. Data statements ..
265  DATA sa/0.3e0/
266  DATA incxs/1, 2, -2, -1/
267  DATA incys/1, -2, 1, -2/
268  DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
269  DATA ns/0, 1, 2, 4/
270  DATA dx1/0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.9e0, -0.3e0,
271  + -0.4e0/
272  DATA dy1/0.5e0, -0.9e0, 0.3e0, 0.7e0, -0.6e0, 0.2e0,
273  + 0.8e0/
274  DATA dt7/0.0e0, 0.30e0, 0.21e0, 0.62e0, 0.0e0,
275  + 0.30e0, -0.07e0, 0.85e0, 0.0e0, 0.30e0, -0.79e0,
276  + -0.74e0, 0.0e0, 0.30e0, 0.33e0, 1.27e0/
277  DATA dt8/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
278  + 0.0e0, 0.68e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
279  + 0.0e0, 0.0e0, 0.68e0, -0.87e0, 0.0e0, 0.0e0,
280  + 0.0e0, 0.0e0, 0.0e0, 0.68e0, -0.87e0, 0.15e0,
281  + 0.94e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
282  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.68e0,
283  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
284  + 0.35e0, -0.9e0, 0.48e0, 0.0e0, 0.0e0, 0.0e0,
285  + 0.0e0, 0.38e0, -0.9e0, 0.57e0, 0.7e0, -0.75e0,
286  + 0.2e0, 0.98e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0,
287  + 0.0e0, 0.0e0, 0.0e0, 0.68e0, 0.0e0, 0.0e0,
288  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.35e0, -0.72e0,
289  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.38e0,
290  + -0.63e0, 0.15e0, 0.88e0, 0.0e0, 0.0e0, 0.0e0,
291  + 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
292  + 0.68e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
293  + 0.0e0, 0.68e0, -0.9e0, 0.33e0, 0.0e0, 0.0e0,
294  + 0.0e0, 0.0e0, 0.68e0, -0.9e0, 0.33e0, 0.7e0,
295  + -0.75e0, 0.2e0, 1.04e0/
296  DATA dt10x/0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
297  + 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
298  + 0.0e0, 0.5e0, -0.9e0, 0.0e0, 0.0e0, 0.0e0,
299  + 0.0e0, 0.0e0, 0.5e0, -0.9e0, 0.3e0, 0.7e0,
300  + 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0,
301  + 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0,
302  + 0.0e0, 0.0e0, 0.0e0, 0.3e0, 0.1e0, 0.5e0, 0.0e0,
303  + 0.0e0, 0.0e0, 0.0e0, 0.8e0, 0.1e0, -0.6e0,
304  + 0.8e0, 0.3e0, -0.3e0, 0.5e0, 0.6e0, 0.0e0,
305  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
306  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.9e0,
307  + 0.1e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.7e0,
308  + 0.1e0, 0.3e0, 0.8e0, -0.9e0, -0.3e0, 0.5e0,
309  + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
310  + 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
311  + 0.5e0, 0.3e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
312  + 0.5e0, 0.3e0, -0.6e0, 0.8e0, 0.0e0, 0.0e0,
313  + 0.0e0/
314  DATA dt10y/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
315  + 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
316  + 0.0e0, 0.6e0, 0.1e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
317  + 0.0e0, 0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.0e0,
318  + 0.0e0, 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
319  + 0.0e0, 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
320  + 0.0e0, 0.0e0, -0.5e0, -0.9e0, 0.6e0, 0.0e0,
321  + 0.0e0, 0.0e0, 0.0e0, -0.4e0, -0.9e0, 0.9e0,
322  + 0.7e0, -0.5e0, 0.2e0, 0.6e0, 0.5e0, 0.0e0,
323  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0,
324  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.5e0,
325  + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
326  + -0.4e0, 0.9e0, -0.5e0, 0.6e0, 0.0e0, 0.0e0,
327  + 0.0e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
328  + 0.0e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
329  + 0.0e0, 0.6e0, -0.9e0, 0.1e0, 0.0e0, 0.0e0,
330  + 0.0e0, 0.0e0, 0.6e0, -0.9e0, 0.1e0, 0.7e0,
331  + -0.5e0, 0.2e0, 0.8e0/
332  DATA ssize1/0.0e0, 0.3e0, 1.6e0, 3.2e0/
333  DATA ssize2/0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
334  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
335  + 0.0e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
336  + 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
337  + 1.17e0, 1.17e0, 1.17e0/
338 * .. Executable Statements ..
339 *
340  DO 120 ki = 1, 4
341  incx = incxs(ki)
342  incy = incys(ki)
343  mx = abs(incx)
344  my = abs(incy)
345 *
346  DO 100 kn = 1, 4
347  n = ns(kn)
348  ksize = min(2,kn)
349  lenx = lens(kn,mx)
350  leny = lens(kn,my)
351 * .. Initialize all argument arrays ..
352  DO 20 i = 1, 7
353  sx(i) = dx1(i)
354  sy(i) = dy1(i)
355  20 CONTINUE
356 *
357  IF (icase.EQ.1) THEN
358 * .. SDOTTEST ..
359  CALL stest1(sdottest(n,sx,incx,sy,incy),dt7(kn,ki),
360  + ssize1(kn),sfac)
361  ELSE IF (icase.EQ.2) THEN
362 * .. SAXPYTEST ..
363  CALL saxpytest(n,sa,sx,incx,sy,incy)
364  DO 40 j = 1, leny
365  sty(j) = dt8(j,kn,ki)
366  40 CONTINUE
367  CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
368  ELSE IF (icase.EQ.5) THEN
369 * .. SCOPYTEST ..
370  DO 60 i = 1, 7
371  sty(i) = dt10y(i,kn,ki)
372  60 CONTINUE
373  CALL scopytest(n,sx,incx,sy,incy)
374  CALL stest(leny,sy,sty,ssize2(1,1),1.0e0)
375  ELSE IF (icase.EQ.6) THEN
376 * .. SSWAPTEST ..
377  CALL sswaptest(n,sx,incx,sy,incy)
378  DO 80 i = 1, 7
379  stx(i) = dt10x(i,kn,ki)
380  sty(i) = dt10y(i,kn,ki)
381  80 CONTINUE
382  CALL stest(lenx,sx,stx,ssize2(1,1),1.0e0)
383  CALL stest(leny,sy,sty,ssize2(1,1),1.0e0)
384  ELSE
385  WRITE (nout,*) ' Shouldn''t be here in CHECK2'
386  stop
387  END IF
388  100 CONTINUE
389  120 CONTINUE
390  RETURN
391  END
392  SUBROUTINE check3(SFAC)
393 * .. Parameters ..
394  INTEGER NOUT
395  parameter (nout=6)
396 * .. Scalar Arguments ..
397  REAL SFAC
398 * .. Scalars in Common ..
399  INTEGER ICASE, INCX, INCY, MODE, N
400  LOGICAL PASS
401 * .. Local Scalars ..
402  REAL SC, SS
403  INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
404 * .. Local Arrays ..
405  REAL COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
406  + dx1(7), dy1(7), mwpc(11), mwps(11), mwpstx(5),
407  + mwpsty(5), mwptx(11,5), mwpty(11,5), mwpx(5),
408  + mwpy(5), ssize2(14,2), stx(7), sty(7), sx(7),
409  + sy(7)
410  INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
411  + mwpiny(11), mwpn(11), ns(4)
412 * .. External Subroutines ..
413  EXTERNAL srottest, stest
414 * .. Intrinsic Functions ..
415  INTRINSIC abs, min
416 * .. Common blocks ..
417  COMMON /combla/icase, n, incx, incy, mode, pass
418 * .. Data statements ..
419  DATA incxs/1, 2, -2, -1/
420  DATA incys/1, -2, 1, -2/
421  DATA lens/1, 1, 2, 4, 1, 1, 3, 7/
422  DATA ns/0, 1, 2, 4/
423  DATA dx1/0.6e0, 0.1e0, -0.5e0, 0.8e0, 0.9e0, -0.3e0,
424  + -0.4e0/
425  DATA dy1/0.5e0, -0.9e0, 0.3e0, 0.7e0, -0.6e0, 0.2e0,
426  + 0.8e0/
427  DATA sc, ss/0.8e0, 0.6e0/
428  DATA dt9x/0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
429  + 0.0e0, 0.78e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
430  + 0.0e0, 0.0e0, 0.78e0, -0.46e0, 0.0e0, 0.0e0,
431  + 0.0e0, 0.0e0, 0.0e0, 0.78e0, -0.46e0, -0.22e0,
432  + 1.06e0, 0.0e0, 0.0e0, 0.0e0, 0.6e0, 0.0e0,
433  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.78e0,
434  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
435  + 0.66e0, 0.1e0, -0.1e0, 0.0e0, 0.0e0, 0.0e0,
436  + 0.0e0, 0.96e0, 0.1e0, -0.76e0, 0.8e0, 0.90e0,
437  + -0.3e0, -0.02e0, 0.6e0, 0.0e0, 0.0e0, 0.0e0,
438  + 0.0e0, 0.0e0, 0.0e0, 0.78e0, 0.0e0, 0.0e0,
439  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, -0.06e0, 0.1e0,
440  + -0.1e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.90e0,
441  + 0.1e0, -0.22e0, 0.8e0, 0.18e0, -0.3e0, -0.02e0,
442  + 0.6e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
443  + 0.78e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
444  + 0.0e0, 0.78e0, 0.26e0, 0.0e0, 0.0e0, 0.0e0,
445  + 0.0e0, 0.0e0, 0.78e0, 0.26e0, -0.76e0, 1.12e0,
446  + 0.0e0, 0.0e0, 0.0e0/
447  DATA dt9y/0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
448  + 0.0e0, 0.04e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
449  + 0.0e0, 0.0e0, 0.04e0, -0.78e0, 0.0e0, 0.0e0,
450  + 0.0e0, 0.0e0, 0.0e0, 0.04e0, -0.78e0, 0.54e0,
451  + 0.08e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0, 0.0e0,
452  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.04e0,
453  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.7e0,
454  + -0.9e0, -0.12e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
455  + 0.64e0, -0.9e0, -0.30e0, 0.7e0, -0.18e0, 0.2e0,
456  + 0.28e0, 0.5e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
457  + 0.0e0, 0.0e0, 0.04e0, 0.0e0, 0.0e0, 0.0e0,
458  + 0.0e0, 0.0e0, 0.0e0, 0.7e0, -1.08e0, 0.0e0,
459  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.64e0, -1.26e0,
460  + 0.54e0, 0.20e0, 0.0e0, 0.0e0, 0.0e0, 0.5e0,
461  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
462  + 0.04e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
463  + 0.0e0, 0.04e0, -0.9e0, 0.18e0, 0.0e0, 0.0e0,
464  + 0.0e0, 0.0e0, 0.04e0, -0.9e0, 0.18e0, 0.7e0,
465  + -0.18e0, 0.2e0, 0.16e0/
466  DATA ssize2/0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
467  + 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0, 0.0e0,
468  + 0.0e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
469  + 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0, 1.17e0,
470  + 1.17e0, 1.17e0, 1.17e0/
471 * .. Executable Statements ..
472 *
473  DO 60 ki = 1, 4
474  incx = incxs(ki)
475  incy = incys(ki)
476  mx = abs(incx)
477  my = abs(incy)
478 *
479  DO 40 kn = 1, 4
480  n = ns(kn)
481  ksize = min(2,kn)
482  lenx = lens(kn,mx)
483  leny = lens(kn,my)
484 *
485  IF (icase.EQ.4) THEN
486 * .. SROTTEST ..
487  DO 20 i = 1, 7
488  sx(i) = dx1(i)
489  sy(i) = dy1(i)
490  stx(i) = dt9x(i,kn,ki)
491  sty(i) = dt9y(i,kn,ki)
492  20 CONTINUE
493  CALL srottest(n,sx,incx,sy,incy,sc,ss)
494  CALL stest(lenx,sx,stx,ssize2(1,ksize),sfac)
495  CALL stest(leny,sy,sty,ssize2(1,ksize),sfac)
496  ELSE
497  WRITE (nout,*) ' Shouldn''t be here in CHECK3'
498  stop
499  END IF
500  40 CONTINUE
501  60 CONTINUE
502 *
503  mwpc(1) = 1
504  DO 80 i = 2, 11
505  mwpc(i) = 0
506  80 CONTINUE
507  mwps(1) = 0
508  DO 100 i = 2, 6
509  mwps(i) = 1
510  100 CONTINUE
511  DO 120 i = 7, 11
512  mwps(i) = -1
513  120 CONTINUE
514  mwpinx(1) = 1
515  mwpinx(2) = 1
516  mwpinx(3) = 1
517  mwpinx(4) = -1
518  mwpinx(5) = 1
519  mwpinx(6) = -1
520  mwpinx(7) = 1
521  mwpinx(8) = 1
522  mwpinx(9) = -1
523  mwpinx(10) = 1
524  mwpinx(11) = -1
525  mwpiny(1) = 1
526  mwpiny(2) = 1
527  mwpiny(3) = -1
528  mwpiny(4) = -1
529  mwpiny(5) = 2
530  mwpiny(6) = 1
531  mwpiny(7) = 1
532  mwpiny(8) = -1
533  mwpiny(9) = -1
534  mwpiny(10) = 2
535  mwpiny(11) = 1
536  DO 140 i = 1, 11
537  mwpn(i) = 5
538  140 CONTINUE
539  mwpn(5) = 3
540  mwpn(10) = 3
541  DO 160 i = 1, 5
542  mwpx(i) = i
543  mwpy(i) = i
544  mwptx(1,i) = i
545  mwpty(1,i) = i
546  mwptx(2,i) = i
547  mwpty(2,i) = -i
548  mwptx(3,i) = 6 - i
549  mwpty(3,i) = i - 6
550  mwptx(4,i) = i
551  mwpty(4,i) = -i
552  mwptx(6,i) = 6 - i
553  mwpty(6,i) = i - 6
554  mwptx(7,i) = -i
555  mwpty(7,i) = i
556  mwptx(8,i) = i - 6
557  mwpty(8,i) = 6 - i
558  mwptx(9,i) = -i
559  mwpty(9,i) = i
560  mwptx(11,i) = i - 6
561  mwpty(11,i) = 6 - i
562  160 CONTINUE
563  mwptx(5,1) = 1
564  mwptx(5,2) = 3
565  mwptx(5,3) = 5
566  mwptx(5,4) = 4
567  mwptx(5,5) = 5
568  mwpty(5,1) = -1
569  mwpty(5,2) = 2
570  mwpty(5,3) = -2
571  mwpty(5,4) = 4
572  mwpty(5,5) = -3
573  mwptx(10,1) = -1
574  mwptx(10,2) = -3
575  mwptx(10,3) = -5
576  mwptx(10,4) = 4
577  mwptx(10,5) = 5
578  mwpty(10,1) = 1
579  mwpty(10,2) = 2
580  mwpty(10,3) = 2
581  mwpty(10,4) = 4
582  mwpty(10,5) = 3
583  DO 200 i = 1, 11
584  incx = mwpinx(i)
585  incy = mwpiny(i)
586  DO 180 k = 1, 5
587  copyx(k) = mwpx(k)
588  copyy(k) = mwpy(k)
589  mwpstx(k) = mwptx(i,k)
590  mwpsty(k) = mwpty(i,k)
591  180 CONTINUE
592  CALL srottest(mwpn(i),copyx,incx,copyy,incy,mwpc(i),mwps(i))
593  CALL stest(5,copyx,mwpstx,mwpstx,sfac)
594  CALL stest(5,copyy,mwpsty,mwpsty,sfac)
595  200 CONTINUE
596  RETURN
597  END
598  SUBROUTINE stest(LEN,SCOMP,STRUE,SSIZE,SFAC)
599 * ********************************* STEST **************************
600 *
601 * THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
602 * SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
603 * NEGLIGIBLE.
604 *
605 * C. L. LAWSON, JPL, 1974 DEC 10
606 *
607 * .. Parameters ..
608  INTEGER NOUT
609  parameter (nout=6)
610 * .. Scalar Arguments ..
611  REAL SFAC
612  INTEGER LEN
613 * .. Array Arguments ..
614  REAL SCOMP(len), SSIZE(len), STRUE(len)
615 * .. Scalars in Common ..
616  INTEGER ICASE, INCX, INCY, MODE, N
617  LOGICAL PASS
618 * .. Local Scalars ..
619  REAL SD
620  INTEGER I
621 * .. External Functions ..
622  REAL SDIFF
623  EXTERNAL sdiff
624 * .. Intrinsic Functions ..
625  INTRINSIC abs
626 * .. Common blocks ..
627  COMMON /combla/icase, n, incx, incy, mode, pass
628 * .. Executable Statements ..
629 *
630  DO 40 i = 1, len
631  sd = scomp(i) - strue(i)
632  IF (sdiff(abs(ssize(i))+abs(sfac*sd),abs(ssize(i))).EQ.0.0e0)
633  + GO TO 40
634 *
635 * HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
636 *
637  IF ( .NOT. pass) GO TO 20
638 * PRINT FAIL MESSAGE AND HEADER.
639  pass = .false.
640  WRITE (nout,99999)
641  WRITE (nout,99998)
642  20 WRITE (nout,99997) icase, n, incx, incy, mode, i, scomp(i),
643  + strue(i), sd, ssize(i)
644  40 CONTINUE
645  RETURN
646 *
647 99999 FORMAT (' FAIL')
648 99998 FORMAT (/' CASE N INCX INCY MODE I ',
649  + ' COMP(I) TRUE(I) DIFFERENCE',
650  + ' SIZE(I)',/1x)
651 99997 FORMAT (1x,i4,i3,3i5,i3,2e36.8,2e12.4)
652  END
653  SUBROUTINE stest1(SCOMP1,STRUE1,SSIZE,SFAC)
654 * ************************* STEST1 *****************************
655 *
656 * THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
657 * REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
658 * ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
659 *
660 * C.L. LAWSON, JPL, 1978 DEC 6
661 *
662 * .. Scalar Arguments ..
663  REAL SCOMP1, SFAC, STRUE1
664 * .. Array Arguments ..
665  REAL SSIZE(*)
666 * .. Local Arrays ..
667  REAL SCOMP(1), STRUE(1)
668 * .. External Subroutines ..
669  EXTERNAL stest
670 * .. Executable Statements ..
671 *
672  scomp(1) = scomp1
673  strue(1) = strue1
674  CALL stest(1,scomp,strue,ssize,sfac)
675 *
676  RETURN
677  END
678  REAL FUNCTION sdiff(SA,SB)
679 * ********************************* SDIFF **************************
680 * COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
681 *
682 * .. Scalar Arguments ..
683  REAL SA, SB
684 * .. Executable Statements ..
685  sdiff = sa - sb
686  RETURN
687  END
688  SUBROUTINE itest1(ICOMP,ITRUE)
689 * ********************************* ITEST1 *************************
690 *
691 * THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
692 * EQUALITY.
693 * C. L. LAWSON, JPL, 1974 DEC 10
694 *
695 * .. Parameters ..
696  INTEGER NOUT
697  parameter (nout=6)
698 * .. Scalar Arguments ..
699  INTEGER ICOMP, ITRUE
700 * .. Scalars in Common ..
701  INTEGER ICASE, INCX, INCY, MODE, N
702  LOGICAL PASS
703 * .. Local Scalars ..
704  INTEGER ID
705 * .. Common blocks ..
706  COMMON /combla/icase, n, incx, incy, mode, pass
707 * .. Executable Statements ..
708 *
709  IF (icomp.EQ.itrue) GO TO 40
710 *
711 * HERE ICOMP IS NOT EQUAL TO ITRUE.
712 *
713  IF ( .NOT. pass) GO TO 20
714 * PRINT FAIL MESSAGE AND HEADER.
715  pass = .false.
716  WRITE (nout,99999)
717  WRITE (nout,99998)
718  20 id = icomp - itrue
719  WRITE (nout,99997) icase, n, incx, incy, mode, icomp, itrue, id
720  40 CONTINUE
721  RETURN
722 *
723 99999 FORMAT (' FAIL')
724 99998 FORMAT (/' CASE N INCX INCY MODE ',
725  + ' COMP TRUE DIFFERENCE',
726  + /1x)
727 99997 FORMAT (1x,i4,i3,3i5,2i36,i12)
728  END
header
subroutine header
Definition: cblat1.f:91
check3
subroutine check3(SFAC)
Definition: dblat1.f:681
itest1
subroutine itest1(ICOMP, ITRUE)
Definition: cblat1.f:686
check1
subroutine check1(SFAC)
Definition: cblat1.f:119
check0
subroutine check0(SFAC)
Definition: dblat1.f:127
stest1
subroutine stest1(SCOMP1, STRUE1, SSIZE, SFAC)
Definition: cblat1.f:620
check2
subroutine check2(SFAC)
Definition: cblat1.f:320
sdiff
real function sdiff(SA, SB)
Definition: cblat1.f:645
stest
subroutine stest(LEN, SCOMP, STRUE, SSIZE, SFAC)
Definition: cblat1.f:564
scblat1
program scblat1
Definition: c_sblat1.f:1