LAPACK  3.4.2
LAPACK: Linear Algebra PACKage
 All Files Functions Groups
dchkrfp.f
Go to the documentation of this file.
1 *> \brief \b DCHKRFP
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 DCHKRFP
12 *
13 *
14 *> \par Purpose:
15 * =============
16 *>
17 *> \verbatim
18 *>
19 *> DCHKRFP is the main test program for the DOUBLE PRECISION linear
20 *> equation routines with RFP storage format
21 *>
22 *> \endverbatim
23 *
24 * Arguments:
25 * ==========
26 *
27 *> \verbatim
28 *> MAXIN INTEGER
29 *> The number of different values that can be used for each of
30 *> M, N, or NB
31 *>
32 *> MAXRHS INTEGER
33 *> The maximum number of right hand sides
34 *>
35 *> NTYPES INTEGER
36 *>
37 *> NMAX INTEGER
38 *> The maximum allowable value for N.
39 *>
40 *> NIN INTEGER
41 *> The unit number for input
42 *>
43 *> NOUT INTEGER
44 *> The unit number for output
45 *> \endverbatim
46 *
47 * Authors:
48 * ========
49 *
50 *> \author Univ. of Tennessee
51 *> \author Univ. of California Berkeley
52 *> \author Univ. of Colorado Denver
53 *> \author NAG Ltd.
54 *
55 *> \date April 2012
56 *
57 *> \ingroup double_lin
58 *
59 * =====================================================================
60  PROGRAM dchkrfp
61 *
62 * -- LAPACK test routine (version 3.4.1) --
63 * -- LAPACK is a software package provided by Univ. of Tennessee, --
64 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
65 * April 2012
66 *
67 * =====================================================================
68 *
69 * .. Parameters ..
70  INTEGER maxin
71  parameter( maxin = 12 )
72  INTEGER nmax
73  parameter( nmax = 50 )
74  INTEGER maxrhs
75  parameter( maxrhs = 16 )
76  INTEGER ntypes
77  parameter( ntypes = 9 )
78  INTEGER nin, nout
79  parameter( nin = 5, nout = 6 )
80 * ..
81 * .. Local Scalars ..
82  LOGICAL fatal, tsterr
83  INTEGER vers_major, vers_minor, vers_patch
84  INTEGER i, nn, nns, nnt
85  DOUBLE PRECISION eps, s1, s2, thresh
86 
87 * ..
88 * .. Local Arrays ..
89  INTEGER nval( maxin ), nsval( maxin ), ntval( ntypes )
90  DOUBLE PRECISION worka( nmax, nmax )
91  DOUBLE PRECISION workasav( nmax, nmax )
92  DOUBLE PRECISION workb( nmax, maxrhs )
93  DOUBLE PRECISION workxact( nmax, maxrhs )
94  DOUBLE PRECISION workbsav( nmax, maxrhs )
95  DOUBLE PRECISION workx( nmax, maxrhs )
96  DOUBLE PRECISION workafac( nmax, nmax )
97  DOUBLE PRECISION workainv( nmax, nmax )
98  DOUBLE PRECISION workarf( (nmax*(nmax+1))/2 )
99  DOUBLE PRECISION workap( (nmax*(nmax+1))/2 )
100  DOUBLE PRECISION workarfinv( (nmax*(nmax+1))/2 )
101  DOUBLE PRECISION d_work_dlatms( 3 * nmax )
102  DOUBLE PRECISION d_work_dpot01( nmax )
103  DOUBLE PRECISION d_temp_dpot02( nmax, maxrhs )
104  DOUBLE PRECISION d_temp_dpot03( nmax, nmax )
105  DOUBLE PRECISION d_work_dlansy( nmax )
106  DOUBLE PRECISION d_work_dpot02( nmax )
107  DOUBLE PRECISION d_work_dpot03( nmax )
108 * ..
109 * .. External Functions ..
110  DOUBLE PRECISION dlamch, dsecnd
111  EXTERNAL dlamch, dsecnd
112 * ..
113 * .. External Subroutines ..
114  EXTERNAL ilaver, ddrvrfp, ddrvrf1, ddrvrf2, ddrvrf3,
115  + ddrvrf4
116 * ..
117 * .. Executable Statements ..
118 *
119  s1 = dsecnd( )
120  fatal = .false.
121 *
122 * Read a dummy line.
123 *
124  READ( nin, fmt = * )
125 *
126 * Report LAPACK version tag (e.g. LAPACK-3.2.0)
127 *
128  CALL ilaver( vers_major, vers_minor, vers_patch )
129  WRITE( nout, fmt = 9994 ) vers_major, vers_minor, vers_patch
130 *
131 * Read the values of N
132 *
133  READ( nin, fmt = * )nn
134  IF( nn.LT.1 ) THEN
135  WRITE( nout, fmt = 9996 )' NN ', nn, 1
136  nn = 0
137  fatal = .true.
138  ELSE IF( nn.GT.maxin ) THEN
139  WRITE( nout, fmt = 9995 )' NN ', nn, maxin
140  nn = 0
141  fatal = .true.
142  END IF
143  READ( nin, fmt = * )( nval( i ), i = 1, nn )
144  DO 10 i = 1, nn
145  IF( nval( i ).LT.0 ) THEN
146  WRITE( nout, fmt = 9996 )' M ', nval( i ), 0
147  fatal = .true.
148  ELSE IF( nval( i ).GT.nmax ) THEN
149  WRITE( nout, fmt = 9995 )' M ', nval( i ), nmax
150  fatal = .true.
151  END IF
152  10 continue
153  IF( nn.GT.0 )
154  $ WRITE( nout, fmt = 9993 )'N ', ( nval( i ), i = 1, nn )
155 *
156 * Read the values of NRHS
157 *
158  READ( nin, fmt = * )nns
159  IF( nns.LT.1 ) THEN
160  WRITE( nout, fmt = 9996 )' NNS', nns, 1
161  nns = 0
162  fatal = .true.
163  ELSE IF( nns.GT.maxin ) THEN
164  WRITE( nout, fmt = 9995 )' NNS', nns, maxin
165  nns = 0
166  fatal = .true.
167  END IF
168  READ( nin, fmt = * )( nsval( i ), i = 1, nns )
169  DO 30 i = 1, nns
170  IF( nsval( i ).LT.0 ) THEN
171  WRITE( nout, fmt = 9996 )'NRHS', nsval( i ), 0
172  fatal = .true.
173  ELSE IF( nsval( i ).GT.maxrhs ) THEN
174  WRITE( nout, fmt = 9995 )'NRHS', nsval( i ), maxrhs
175  fatal = .true.
176  END IF
177  30 continue
178  IF( nns.GT.0 )
179  $ WRITE( nout, fmt = 9993 )'NRHS', ( nsval( i ), i = 1, nns )
180 *
181 * Read the matrix types
182 *
183  READ( nin, fmt = * )nnt
184  IF( nnt.LT.1 ) THEN
185  WRITE( nout, fmt = 9996 )' NMA', nnt, 1
186  nnt = 0
187  fatal = .true.
188  ELSE IF( nnt.GT.ntypes ) THEN
189  WRITE( nout, fmt = 9995 )' NMA', nnt, ntypes
190  nnt = 0
191  fatal = .true.
192  END IF
193  READ( nin, fmt = * )( ntval( i ), i = 1, nnt )
194  DO 320 i = 1, nnt
195  IF( ntval( i ).LT.0 ) THEN
196  WRITE( nout, fmt = 9996 )'TYPE', ntval( i ), 0
197  fatal = .true.
198  ELSE IF( ntval( i ).GT.ntypes ) THEN
199  WRITE( nout, fmt = 9995 )'TYPE', ntval( i ), ntypes
200  fatal = .true.
201  END IF
202  320 continue
203  IF( nnt.GT.0 )
204  $ WRITE( nout, fmt = 9993 )'TYPE', ( ntval( i ), i = 1, nnt )
205 *
206 * Read the threshold value for the test ratios.
207 *
208  READ( nin, fmt = * )thresh
209  WRITE( nout, fmt = 9992 )thresh
210 *
211 * Read the flag that indicates whether to test the error exits.
212 *
213  READ( nin, fmt = * )tsterr
214 *
215  IF( fatal ) THEN
216  WRITE( nout, fmt = 9999 )
217  stop
218  END IF
219 *
220  IF( fatal ) THEN
221  WRITE( nout, fmt = 9999 )
222  stop
223  END IF
224 *
225 * Calculate and print the machine dependent constants.
226 *
227  eps = dlamch( 'Underflow threshold' )
228  WRITE( nout, fmt = 9991 )'underflow', eps
229  eps = dlamch( 'Overflow threshold' )
230  WRITE( nout, fmt = 9991 )'overflow ', eps
231  eps = dlamch( 'Epsilon' )
232  WRITE( nout, fmt = 9991 )'precision', eps
233  WRITE( nout, fmt = * )
234 *
235 * Test the error exit of:
236 *
237  IF( tsterr )
238  $ CALL derrrfp( nout )
239 *
240 * Test the routines: dpftrf, dpftri, dpftrs (as in DDRVPO).
241 * This also tests the routines: dtfsm, dtftri, dtfttr, dtrttf.
242 *
243  CALL ddrvrfp( nout, nn, nval, nns, nsval, nnt, ntval, thresh,
244  $ worka, workasav, workafac, workainv, workb,
245  $ workbsav, workxact, workx, workarf, workarfinv,
246  $ d_work_dlatms, d_work_dpot01, d_temp_dpot02,
247  $ d_temp_dpot03, d_work_dlansy, d_work_dpot02,
248  $ d_work_dpot03 )
249 *
250 * Test the routine: dlansf
251 *
252  CALL ddrvrf1( nout, nn, nval, thresh, worka, nmax, workarf,
253  + d_work_dlansy )
254 *
255 * Test the convertion routines:
256 * dtfttp, dtpttf, dtfttr, dtrttf, dtrttp and dtpttr.
257 *
258  CALL ddrvrf2( nout, nn, nval, worka, nmax, workarf,
259  + workap, workasav )
260 *
261 * Test the routine: dtfsm
262 *
263  CALL ddrvrf3( nout, nn, nval, thresh, worka, nmax, workarf,
264  + workainv, workafac, d_work_dlansy,
265  + d_work_dpot03, d_work_dpot01 )
266 *
267 *
268 * Test the routine: dsfrk
269 *
270  CALL ddrvrf4( nout, nn, nval, thresh, worka, workafac, nmax,
271  + workarf, workainv, nmax, d_work_dlansy)
272 *
273  CLOSE ( nin )
274  s2 = dsecnd( )
275  WRITE( nout, fmt = 9998 )
276  WRITE( nout, fmt = 9997 )s2 - s1
277 *
278  9999 format( / ' Execution not attempted due to input errors' )
279  9998 format( / ' End of tests' )
280  9997 format( ' Total time used = ', f12.2, ' seconds', / )
281  9996 format( ' !! Invalid input value: ', a4, '=', i6, '; must be >=',
282  $ i6 )
283  9995 format( ' !! Invalid input value: ', a4, '=', i6, '; must be <=',
284  $ i6 )
285  9994 format( / ' Tests of the DOUBLE PRECISION LAPACK RFP routines ',
286  $ / ' LAPACK VERSION ', i1, '.', i1, '.', i1,
287  $ / / ' The following parameter values will be used:' )
288  9993 format( 4x, a4, ': ', 10i6, / 11x, 10i6 )
289  9992 format( / ' Routines pass computational tests if test ratio is ',
290  $ 'less than', f8.2, / )
291  9991 format( ' Relative machine ', a, ' is taken to be', d16.6 )
292 *
293 * End of DCHKRFP
294 *
295  END