LAPACK  3.9.1
LAPACK: Linear Algebra PACKage
schkrfp.f
Go to the documentation of this file.
1 *> \brief \b SCHKRFP
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 SCHKRFP
12 *
13 *
14 *> \par Purpose:
15 * =============
16 *>
17 *> \verbatim
18 *>
19 *> SCHKRFP is the main test program for the REAL 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 *> \ingroup single_lin
56 *
57 * =====================================================================
58  PROGRAM schkrfp
59 *
60 * -- LAPACK test routine --
61 * -- LAPACK is a software package provided by Univ. of Tennessee, --
62 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
63 *
64 * =====================================================================
65 *
66 * .. Parameters ..
67  INTEGER maxin
68  parameter( maxin = 12 )
69  INTEGER nmax
70  parameter( nmax = 50 )
71  INTEGER maxrhs
72  parameter( maxrhs = 16 )
73  INTEGER ntypes
74  parameter( ntypes = 9 )
75  INTEGER nin, nout
76  parameter( nin = 5, nout = 6 )
77 * ..
78 * .. Local Scalars ..
79  LOGICAL fatal, tsterr
80  INTEGER vers_major, vers_minor, vers_patch
81  INTEGER i, nn, nns, nnt
82  REAL eps, s1, s2, thresh
83 * ..
84 * .. Local Arrays ..
85  INTEGER nval( maxin ), nsval( maxin ), ntval( ntypes )
86  REAL worka( nmax, nmax )
87  REAL workasav( nmax, nmax )
88  REAL workb( nmax, maxrhs )
89  REAL workxact( nmax, maxrhs )
90  REAL workbsav( nmax, maxrhs )
91  REAL workx( nmax, maxrhs )
92  REAL workafac( nmax, nmax )
93  REAL workainv( nmax, nmax )
94  REAL workarf( (nmax*(nmax+1))/2 )
95  REAL workap( (nmax*(nmax+1))/2 )
96  REAL workarfinv( (nmax*(nmax+1))/2 )
97  REAL s_work_slatms( 3 * nmax )
98  REAL s_work_spot01( nmax )
99  REAL s_temp_spot02( nmax, maxrhs )
100  REAL s_temp_spot03( nmax, nmax )
101  REAL s_work_slansy( nmax )
102  REAL s_work_spot02( nmax )
103  REAL s_work_spot03( nmax )
104 * ..
105 * .. External Functions ..
106  REAL slamch, second
107  EXTERNAL slamch, second
108 * ..
109 * .. External Subroutines ..
110  EXTERNAL ilaver, sdrvrfp, sdrvrf1, sdrvrf2, sdrvrf3,
111  + sdrvrf4
112 * ..
113 * .. Executable Statements ..
114 *
115  s1 = second( )
116  fatal = .false.
117 *
118 * Read a dummy line.
119 *
120  READ( nin, fmt = * )
121 *
122 * Report LAPACK version tag (e.g. LAPACK-3.2.0)
123 *
124  CALL ilaver( vers_major, vers_minor, vers_patch )
125  WRITE( nout, fmt = 9994 ) vers_major, vers_minor, vers_patch
126 *
127 * Read the values of N
128 *
129  READ( nin, fmt = * )nn
130  IF( nn.LT.1 ) THEN
131  WRITE( nout, fmt = 9996 )' NN ', nn, 1
132  nn = 0
133  fatal = .true.
134  ELSE IF( nn.GT.maxin ) THEN
135  WRITE( nout, fmt = 9995 )' NN ', nn, maxin
136  nn = 0
137  fatal = .true.
138  END IF
139  READ( nin, fmt = * )( nval( i ), i = 1, nn )
140  DO 10 i = 1, nn
141  IF( nval( i ).LT.0 ) THEN
142  WRITE( nout, fmt = 9996 )' M ', nval( i ), 0
143  fatal = .true.
144  ELSE IF( nval( i ).GT.nmax ) THEN
145  WRITE( nout, fmt = 9995 )' M ', nval( i ), nmax
146  fatal = .true.
147  END IF
148  10 CONTINUE
149  IF( nn.GT.0 )
150  $ WRITE( nout, fmt = 9993 )'N ', ( nval( i ), i = 1, nn )
151 *
152 * Read the values of NRHS
153 *
154  READ( nin, fmt = * )nns
155  IF( nns.LT.1 ) THEN
156  WRITE( nout, fmt = 9996 )' NNS', nns, 1
157  nns = 0
158  fatal = .true.
159  ELSE IF( nns.GT.maxin ) THEN
160  WRITE( nout, fmt = 9995 )' NNS', nns, maxin
161  nns = 0
162  fatal = .true.
163  END IF
164  READ( nin, fmt = * )( nsval( i ), i = 1, nns )
165  DO 30 i = 1, nns
166  IF( nsval( i ).LT.0 ) THEN
167  WRITE( nout, fmt = 9996 )'NRHS', nsval( i ), 0
168  fatal = .true.
169  ELSE IF( nsval( i ).GT.maxrhs ) THEN
170  WRITE( nout, fmt = 9995 )'NRHS', nsval( i ), maxrhs
171  fatal = .true.
172  END IF
173  30 CONTINUE
174  IF( nns.GT.0 )
175  $ WRITE( nout, fmt = 9993 )'NRHS', ( nsval( i ), i = 1, nns )
176 *
177 * Read the matrix types
178 *
179  READ( nin, fmt = * )nnt
180  IF( nnt.LT.1 ) THEN
181  WRITE( nout, fmt = 9996 )' NMA', nnt, 1
182  nnt = 0
183  fatal = .true.
184  ELSE IF( nnt.GT.ntypes ) THEN
185  WRITE( nout, fmt = 9995 )' NMA', nnt, ntypes
186  nnt = 0
187  fatal = .true.
188  END IF
189  READ( nin, fmt = * )( ntval( i ), i = 1, nnt )
190  DO 320 i = 1, nnt
191  IF( ntval( i ).LT.0 ) THEN
192  WRITE( nout, fmt = 9996 )'TYPE', ntval( i ), 0
193  fatal = .true.
194  ELSE IF( ntval( i ).GT.ntypes ) THEN
195  WRITE( nout, fmt = 9995 )'TYPE', ntval( i ), ntypes
196  fatal = .true.
197  END IF
198  320 CONTINUE
199  IF( nnt.GT.0 )
200  $ WRITE( nout, fmt = 9993 )'TYPE', ( ntval( i ), i = 1, nnt )
201 *
202 * Read the threshold value for the test ratios.
203 *
204  READ( nin, fmt = * )thresh
205  WRITE( nout, fmt = 9992 )thresh
206 *
207 * Read the flag that indicates whether to test the error exits.
208 *
209  READ( nin, fmt = * )tsterr
210 *
211  IF( fatal ) THEN
212  WRITE( nout, fmt = 9999 )
213  stop
214  END IF
215 *
216 * Calculate and print the machine dependent constants.
217 *
218  eps = slamch( 'Underflow threshold' )
219  WRITE( nout, fmt = 9991 )'underflow', eps
220  eps = slamch( 'Overflow threshold' )
221  WRITE( nout, fmt = 9991 )'overflow ', eps
222  eps = slamch( 'Epsilon' )
223  WRITE( nout, fmt = 9991 )'precision', eps
224  WRITE( nout, fmt = * )
225 *
226 * Test the error exit of:
227 *
228  IF( tsterr )
229  $ CALL serrrfp( nout )
230 *
231 * Test the routines: spftrf, spftri, spftrs (as in SDRVPO).
232 * This also tests the routines: stfsm, stftri, stfttr, strttf.
233 *
234  CALL sdrvrfp( nout, nn, nval, nns, nsval, nnt, ntval, thresh,
235  $ worka, workasav, workafac, workainv, workb,
236  $ workbsav, workxact, workx, workarf, workarfinv,
237  $ s_work_slatms, s_work_spot01, s_temp_spot02,
238  $ s_temp_spot03, s_work_slansy, s_work_spot02,
239  $ s_work_spot03 )
240 *
241 * Test the routine: slansf
242 *
243  CALL sdrvrf1( nout, nn, nval, thresh, worka, nmax, workarf,
244  + s_work_slansy )
245 *
246 * Test the conversion routines:
247 * stfttp, stpttf, stfttr, strttf, strttp and stpttr.
248 *
249  CALL sdrvrf2( nout, nn, nval, worka, nmax, workarf,
250  + workap, workasav )
251 *
252 * Test the routine: stfsm
253 *
254  CALL sdrvrf3( nout, nn, nval, thresh, worka, nmax, workarf,
255  + workainv, workafac, s_work_slansy,
256  + s_work_spot03, s_work_spot01 )
257 *
258 *
259 * Test the routine: ssfrk
260 *
261  CALL sdrvrf4( nout, nn, nval, thresh, worka, workafac, nmax,
262  + workarf, workainv, nmax, s_work_slansy)
263 *
264  CLOSE ( nin )
265  s2 = second( )
266  WRITE( nout, fmt = 9998 )
267  WRITE( nout, fmt = 9997 )s2 - s1
268 *
269  9999 FORMAT( / ' Execution not attempted due to input errors' )
270  9998 FORMAT( / ' End of tests' )
271  9997 FORMAT( ' Total time used = ', f12.2, ' seconds', / )
272  9996 FORMAT( ' !! Invalid input value: ', a4, '=', i6, '; must be >=',
273  $ i6 )
274  9995 FORMAT( ' !! Invalid input value: ', a4, '=', i6, '; must be <=',
275  $ i6 )
276  9994 FORMAT( / ' Tests of the REAL LAPACK RFP routines ',
277  $ / ' LAPACK VERSION ', i1, '.', i1, '.', i1,
278  $ / / ' The following parameter values will be used:' )
279  9993 FORMAT( 4x, a4, ': ', 10i6, / 11x, 10i6 )
280  9992 FORMAT( / ' Routines pass computational tests if test ratio is ',
281  $ 'less than', f8.2, / )
282  9991 FORMAT( ' Relative machine ', a, ' is taken to be', d16.6 )
283 *
284 * End of SCHKRFP
285 *
286  END
subroutine serrrfp(NUNIT)
SERRRFP
Definition: serrrfp.f:52
subroutine sdrvrfp(NOUT, NN, NVAL, NNS, NSVAL, NNT, NTVAL, THRESH, A, ASAV, AFAC, AINV, B, BSAV, XACT, X, ARF, ARFINV, S_WORK_SLATMS, S_WORK_SPOT01, S_TEMP_SPOT02, S_TEMP_SPOT03, S_WORK_SLANSY, S_WORK_SPOT02, S_WORK_SPOT03)
SDRVRFP
Definition: sdrvrfp.f:238
subroutine sdrvrf2(NOUT, NN, NVAL, A, LDA, ARF, AP, ASAV)
SDRVRF2
Definition: sdrvrf2.f:89
subroutine sdrvrf3(NOUT, NN, NVAL, THRESH, A, LDA, ARF, B1, B2, S_WORK_SLANGE, S_WORK_SGEQRF, TAU)
SDRVRF3
Definition: sdrvrf3.f:118
subroutine sdrvrf4(NOUT, NN, NVAL, THRESH, C1, C2, LDC, CRF, A, LDA, S_WORK_SLANGE)
SDRVRF4
Definition: sdrvrf4.f:118
subroutine sdrvrf1(NOUT, NN, NVAL, THRESH, A, LDA, ARF, WORK)
SDRVRF1
Definition: sdrvrf1.f:94
program schkrfp
SCHKRFP
Definition: schkrfp.f:58
subroutine ilaver(VERS_MAJOR, VERS_MINOR, VERS_PATCH)
ILAVER returns the LAPACK version.
Definition: ilaver.f:51
real function second()
SECOND Using ETIME
real function slamch(CMACH)
SLAMCH
Definition: slamch.f:68