LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
dchkab.f
Go to the documentation of this file.
1 *> \brief \b DCHKAB
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 DCHKAB
12 *
13 *
14 *> \par Purpose:
15 * =============
16 *>
17 *> \verbatim
18 *>
19 *> DCHKAB is the test program for the DOUBLE PRECISION LAPACK
20 *> DSGESV/DSPOSV routine
21 *>
22 *> The program must be driven by a short data file. The first 5 records
23 *> specify problem dimensions and program options using list-directed
24 *> input. The remaining lines specify the LAPACK test paths and the
25 *> number of matrix types to use in testing. An annotated example of a
26 *> data file can be obtained by deleting the first 3 characters from the
27 *> following 10 lines:
28 *> Data file for testing DOUBLE PRECISION LAPACK DSGESV
29 *> 7 Number of values of M
30 *> 0 1 2 3 5 10 16 Values of M (row dimension)
31 *> 1 Number of values of NRHS
32 *> 2 Values of NRHS (number of right hand sides)
33 *> 20.0 Threshold value of test ratio
34 *> T Put T to test the LAPACK routines
35 *> T Put T to test the error exits
36 *> DGE 11 List types on next line if 0 < NTYPES < 11
37 *> DPO 9 List types on next line if 0 < NTYPES < 9
38 *> \endverbatim
39 *
40 * Arguments:
41 * ==========
42 *
43 *> \verbatim
44 *> NMAX INTEGER
45 *> The maximum allowable value for N
46 *>
47 *> MAXIN INTEGER
48 *> The number of different values that can be used for each of
49 *> M, N, NRHS, NB, and NX
50 *>
51 *> MAXRHS INTEGER
52 *> The maximum number of right hand sides
53 *>
54 *> NIN INTEGER
55 *> The unit number for input
56 *>
57 *> NOUT INTEGER
58 *> The unit number for output
59 *> \endverbatim
60 *
61 * Authors:
62 * ========
63 *
64 *> \author Univ. of Tennessee
65 *> \author Univ. of California Berkeley
66 *> \author Univ. of Colorado Denver
67 *> \author NAG Ltd.
68 *
69 *> \date April 2012
70 *
71 *> \ingroup double_lin
72 *
73 * =====================================================================
74  PROGRAM dchkab
75 *
76 * -- LAPACK test routine (version 3.4.1) --
77 * -- LAPACK is a software package provided by Univ. of Tennessee, --
78 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
79 * April 2012
80 *
81 * =====================================================================
82 *
83 * .. Parameters ..
84  INTEGER nmax
85  parameter( nmax = 132 )
86  INTEGER maxin
87  parameter( maxin = 12 )
88  INTEGER maxrhs
89  parameter( maxrhs = 16 )
90  INTEGER matmax
91  parameter( matmax = 30 )
92  INTEGER nin, nout
93  parameter( nin = 5, nout = 6 )
94  INTEGER ldamax
95  parameter( ldamax = nmax )
96 * ..
97 * .. Local Scalars ..
98  LOGICAL fatal, tstdrv, tsterr
99  CHARACTER c1
100  CHARACTER*2 c2
101  CHARACTER*3 path
102  CHARACTER*10 intstr
103  CHARACTER*72 aline
104  INTEGER i, ic, k, lda, nm, nmats,
105  $ nns, nrhs, ntypes,
106  $ vers_major, vers_minor, vers_patch
107  DOUBLE PRECISION eps, s1, s2, thresh
108  REAL seps
109 * ..
110 * .. Local Arrays ..
111  LOGICAL dotype( matmax )
112  INTEGER iwork( nmax ), mval( maxin ), nsval( maxin )
113  DOUBLE PRECISION a( ldamax*nmax, 2 ), b( nmax*maxrhs, 2 ),
114  $ rwork( nmax ), work( nmax*maxrhs*2 )
115  REAL swork(nmax*(nmax+maxrhs))
116 * ..
117 * .. External Functions ..
118  DOUBLE PRECISION dlamch, dsecnd
119  LOGICAL lsame, lsamen
120  REAL slamch
121  EXTERNAL lsame, lsamen, dlamch, dsecnd, slamch
122 * ..
123 * .. External Subroutines ..
124  EXTERNAL alareq, ddrvab, ddrvac, derrab, derrac,
125  $ ilaver
126 * ..
127 * .. Scalars in Common ..
128  LOGICAL lerr, ok
129  CHARACTER*32 srnamt
130  INTEGER infot, nunit
131 * ..
132 * .. Common blocks ..
133  common / infoc / infot, nunit, ok, lerr
134  common / srnamc / srnamt
135 * ..
136 * .. Data statements ..
137  DATA intstr / '0123456789' /
138 * ..
139 * .. Executable Statements ..
140 *
141  s1 = dsecnd( )
142  lda = nmax
143  fatal = .false.
144 *
145 * Read a dummy line.
146 *
147  READ( nin, fmt = * )
148 *
149 * Report values of parameters.
150 *
151  CALL ilaver( vers_major, vers_minor, vers_patch )
152  WRITE( nout, fmt = 9994 ) vers_major, vers_minor, vers_patch
153 *
154 * Read the values of M
155 *
156  READ( nin, fmt = * )nm
157  IF( nm.LT.1 ) THEN
158  WRITE( nout, fmt = 9996 )' NM ', nm, 1
159  nm = 0
160  fatal = .true.
161  ELSE IF( nm.GT.maxin ) THEN
162  WRITE( nout, fmt = 9995 )' NM ', nm, maxin
163  nm = 0
164  fatal = .true.
165  END IF
166  READ( nin, fmt = * )( mval( i ), i = 1, nm )
167  DO 10 i = 1, nm
168  IF( mval( i ).LT.0 ) THEN
169  WRITE( nout, fmt = 9996 )' M ', mval( i ), 0
170  fatal = .true.
171  ELSE IF( mval( i ).GT.nmax ) THEN
172  WRITE( nout, fmt = 9995 )' M ', mval( i ), nmax
173  fatal = .true.
174  END IF
175  10 continue
176  IF( nm.GT.0 )
177  $ WRITE( nout, fmt = 9993 )'M ', ( mval( i ), i = 1, nm )
178 *
179 * Read the values of NRHS
180 *
181  READ( nin, fmt = * )nns
182  IF( nns.LT.1 ) THEN
183  WRITE( nout, fmt = 9996 )' NNS', nns, 1
184  nns = 0
185  fatal = .true.
186  ELSE IF( nns.GT.maxin ) THEN
187  WRITE( nout, fmt = 9995 )' NNS', nns, maxin
188  nns = 0
189  fatal = .true.
190  END IF
191  READ( nin, fmt = * )( nsval( i ), i = 1, nns )
192  DO 30 i = 1, nns
193  IF( nsval( i ).LT.0 ) THEN
194  WRITE( nout, fmt = 9996 )'NRHS', nsval( i ), 0
195  fatal = .true.
196  ELSE IF( nsval( i ).GT.maxrhs ) THEN
197  WRITE( nout, fmt = 9995 )'NRHS', nsval( i ), maxrhs
198  fatal = .true.
199  END IF
200  30 continue
201  IF( nns.GT.0 )
202  $ WRITE( nout, fmt = 9993 )'NRHS', ( nsval( i ), i = 1, nns )
203 *
204 * Read the threshold value for the test ratios.
205 *
206  READ( nin, fmt = * )thresh
207  WRITE( nout, fmt = 9992 )thresh
208 *
209 * Read the flag that indicates whether to test the driver routine.
210 *
211  READ( nin, fmt = * )tstdrv
212 *
213 * Read the flag that indicates whether to test the error exits.
214 *
215  READ( nin, fmt = * )tsterr
216 *
217  IF( fatal ) THEN
218  WRITE( nout, fmt = 9999 )
219  stop
220  END IF
221 *
222 * Calculate and print the machine dependent constants.
223 *
224  seps = slamch( 'Underflow threshold' )
225  WRITE( nout, fmt = 9991 )'(single precision) underflow', seps
226  seps = slamch( 'Overflow threshold' )
227  WRITE( nout, fmt = 9991 )'(single precision) overflow ', seps
228  seps = slamch( 'Epsilon' )
229  WRITE( nout, fmt = 9991 )'(single precision) precision', seps
230  WRITE( nout, fmt = * )
231 *
232  eps = dlamch( 'Underflow threshold' )
233  WRITE( nout, fmt = 9991 )'(double precision) underflow', eps
234  eps = dlamch( 'Overflow threshold' )
235  WRITE( nout, fmt = 9991 )'(double precision) overflow ', eps
236  eps = dlamch( 'Epsilon' )
237  WRITE( nout, fmt = 9991 )'(double precision) precision', eps
238  WRITE( nout, fmt = * )
239 *
240  80 continue
241 *
242 * Read a test path and the number of matrix types to use.
243 *
244  READ( nin, fmt = '(A72)', END = 140 )aline
245  path = aline( 1: 3 )
246  nmats = matmax
247  i = 3
248  90 continue
249  i = i + 1
250  IF( i.GT.72 ) THEN
251  nmats = matmax
252  go to 130
253  END IF
254  IF( aline( i: i ).EQ.' ' )
255  $ go to 90
256  nmats = 0
257  100 continue
258  c1 = aline( i: i )
259  DO 110 k = 1, 10
260  IF( c1.EQ.intstr( k: k ) ) THEN
261  ic = k - 1
262  go to 120
263  END IF
264  110 continue
265  go to 130
266  120 continue
267  nmats = nmats*10 + ic
268  i = i + 1
269  IF( i.GT.72 )
270  $ go to 130
271  go to 100
272  130 continue
273  c1 = path( 1: 1 )
274  c2 = path( 2: 3 )
275  nrhs = nsval( 1 )
276 *
277 * Check first character for correct precision.
278 *
279  IF( .NOT.lsame( c1, 'Double precision' ) ) THEN
280  WRITE( nout, fmt = 9990 )path
281 
282 *
283  ELSE IF( nmats.LE.0 ) THEN
284 *
285 * Check for a positive number of tests requested.
286 *
287  WRITE( nout, fmt = 9989 )path
288  go to 140
289 *
290  ELSE IF( lsamen( 2, c2, 'GE' ) ) THEN
291 *
292 * GE: general matrices
293 *
294  ntypes = 11
295  CALL alareq( 'DGE', nmats, dotype, ntypes, nin, nout )
296 *
297 * Test the error exits
298 *
299  IF( tsterr )
300  $ CALL derrab( nout )
301 *
302  IF( tstdrv ) THEN
303  CALL ddrvab( dotype, nm, mval, nns,
304  $ nsval, thresh, lda, a( 1, 1 ),
305  $ a( 1, 2 ), b( 1, 1 ), b( 1, 2 ),
306  $ work, rwork, swork, iwork, nout )
307  ELSE
308  WRITE( nout, fmt = 9989 )'DSGESV'
309  END IF
310 *
311  ELSE IF( lsamen( 2, c2, 'PO' ) ) THEN
312 *
313 * PO: positive definite matrices
314 *
315  ntypes = 9
316  CALL alareq( 'DPO', nmats, dotype, ntypes, nin, nout )
317 *
318 *
319  IF( tsterr )
320  $ CALL derrac( nout )
321 *
322 *
323  IF( tstdrv ) THEN
324  CALL ddrvac( dotype, nm, mval, nns, nsval,
325  $ thresh, lda, a( 1, 1 ), a( 1, 2 ),
326  $ b( 1, 1 ), b( 1, 2 ),
327  $ work, rwork, swork, nout )
328  ELSE
329  WRITE( nout, fmt = 9989 )path
330  END IF
331  ELSE
332 *
333  END IF
334 *
335 * Go back to get another input line.
336 *
337  go to 80
338 *
339 * Branch to this line when the last record is read.
340 *
341  140 continue
342  CLOSE ( nin )
343  s2 = dsecnd( )
344  WRITE( nout, fmt = 9998 )
345  WRITE( nout, fmt = 9997 )s2 - s1
346 *
347  9999 format( / ' Execution not attempted due to input errors' )
348  9998 format( / ' End of tests' )
349  9997 format( ' Total time used = ', f12.2, ' seconds', / )
350  9996 format( ' Invalid input value: ', a4, '=', i6, '; must be >=',
351  $ i6 )
352  9995 format( ' Invalid input value: ', a4, '=', i6, '; must be <=',
353  $ i6 )
354  9994 format( ' Tests of the DOUBLE PRECISION LAPACK DSGESV/DSPOSV',
355  $ ' routines ',
356  $ / ' LAPACK VERSION ', i1, '.', i1, '.', i1,
357  $ / / ' The following parameter values will be used:' )
358  9993 format( 4x, a4, ': ', 10i6, / 11x, 10i6 )
359  9992 format( / ' Routines pass computational tests if test ratio is ',
360  $ 'less than', f8.2, / )
361  9991 format( ' Relative machine ', a, ' is taken to be', d16.6 )
362  9990 format( / 1x, a6, ' routines were not tested' )
363  9989 format( / 1x, a6, ' driver routines were not tested' )
364 *
365 * End of DCHKAB
366 *
367  END