LAPACK  3.8.0
LAPACK: Linear Algebra PACKage

◆ check0()

subroutine check0 ( real  SFAC)

Definition at line 127 of file sblat1.f.

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