1 SUBROUTINE SCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL,
2 $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK,
3 $ RWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.1) --
6 * Craig Lucas, University of Manchester / NAG Ltd.
7 * October, 2008
8 *
9 * .. Scalar Arguments ..
10 REAL THRESH
11 INTEGER NMAX, NN, NNB, NOUT, NRANK
12 LOGICAL TSTERR
13 * ..
14 * .. Array Arguments ..
15 REAL A( * ), AFAC( * ), PERM( * ), RWORK( * ),
16 $ WORK( * )
17 INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
18 LOGICAL DOTYPE( * )
19 * ..
20 *
21 * Purpose
22 * =======
23 *
24 * SCHKPS tests SPSTRF.
25 *
26 * Arguments
27 * =========
28 *
29 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
30 * The matrix types to be used for testing. Matrices of type j
31 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
32 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
33 *
34 * NN (input) INTEGER
35 * The number of values of N contained in the vector NVAL.
36 *
37 * NVAL (input) INTEGER array, dimension (NN)
38 * The values of the matrix dimension N.
39 *
40 * NNB (input) INTEGER
41 * The number of values of NB contained in the vector NBVAL.
42 *
43 * NBVAL (input) INTEGER array, dimension (NBVAL)
44 * The values of the block size NB.
45 *
46 * NRANK (input) INTEGER
47 * The number of values of RANK contained in the vector RANKVAL.
48 *
49 * RANKVAL (input) INTEGER array, dimension (NBVAL)
50 * The values of the block size NB.
51 *
52 * THRESH (input) REAL
53 * The threshold value for the test ratios. A result is
54 * included in the output file if RESULT >= THRESH. To have
55 * every test ratio printed, use THRESH = 0.
56 *
57 * TSTERR (input) LOGICAL
58 * Flag that indicates whether error exits are to be tested.
59 *
60 * NMAX (input) INTEGER
61 * The maximum value permitted for N, used in dimensioning the
62 * work arrays.
63 *
64 * A (workspace) REAL array, dimension (NMAX*NMAX)
65 *
66 * AFAC (workspace) REAL array, dimension (NMAX*NMAX)
67 *
68 * PERM (workspace) REAL array, dimension (NMAX*NMAX)
69 *
70 * PIV (workspace) INTEGER array, dimension (NMAX)
71 *
72 * WORK (workspace) REAL array, dimension (NMAX*3)
73 *
74 * RWORK (workspace) REAL array, dimension (NMAX)
75 *
76 * NOUT (input) INTEGER
77 * The unit number for output.
78 *
79 * =====================================================================
80 *
81 * .. Parameters ..
82 REAL ONE
83 PARAMETER ( ONE = 1.0E+0 )
84 INTEGER NTYPES
85 PARAMETER ( NTYPES = 9 )
86 * ..
87 * .. Local Scalars ..
88 REAL ANORM, CNDNUM, RESULT, TOL
89 INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO,
90 $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL,
91 $ NIMAT, NRUN, RANK, RANKDIFF
92 CHARACTER DIST, TYPE, UPLO
93 CHARACTER*3 PATH
94 * ..
95 * .. Local Arrays ..
96 INTEGER ISEED( 4 ), ISEEDY( 4 )
97 CHARACTER UPLOS( 2 )
98 * ..
99 * .. External Subroutines ..
100 EXTERNAL ALAERH, ALAHD, ALASUM, SERRPS, SLACPY, SLATB5,
101 $ SLATMT, SPST01, SPSTRF, XLAENV
102 * ..
103 * .. Scalars in Common ..
104 INTEGER INFOT, NUNIT
105 LOGICAL LERR, OK
106 CHARACTER*32 SRNAMT
107 * ..
108 * .. Common blocks ..
109 COMMON / INFOC / INFOT, NUNIT, OK, LERR
110 COMMON / SRNAMC / SRNAMT
111 * ..
112 * .. Intrinsic Functions ..
113 INTRINSIC MAX, REAL, CEILING
114 * ..
115 * .. Data statements ..
116 DATA ISEEDY / 1988, 1989, 1990, 1991 /
117 DATA UPLOS / 'U', 'L' /
118 * ..
119 * .. Executable Statements ..
120 *
121 * Initialize constants and the random number seed.
122 *
123 PATH( 1: 1 ) = 'Single Precision'
124 PATH( 2: 3 ) = 'PS'
125 NRUN = 0
126 NFAIL = 0
127 NERRS = 0
128 DO 100 I = 1, 4
129 ISEED( I ) = ISEEDY( I )
130 100 CONTINUE
131 *
132 * Test the error exits
133 *
134 IF( TSTERR )
135 $ CALL SERRPS( PATH, NOUT )
136 INFOT = 0
137 CALL XLAENV( 2, 2 )
138 *
139 * Do for each value of N in NVAL
140 *
141 DO 150 IN = 1, NN
142 N = NVAL( IN )
143 LDA = MAX( N, 1 )
144 NIMAT = NTYPES
145 IF( N.LE.0 )
146 $ NIMAT = 1
147 *
148 IZERO = 0
149 DO 140 IMAT = 1, NIMAT
150 *
151 * Do the tests only if DOTYPE( IMAT ) is true.
152 *
153 IF( .NOT.DOTYPE( IMAT ) )
154 $ GO TO 140
155 *
156 * Do for each value of RANK in RANKVAL
157 *
158 DO 130 IRANK = 1, NRANK
159 *
160 * Only repeat test 3 to 5 for different ranks
161 * Other tests use full rank
162 *
163 IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 )
164 $ GO TO 130
165 *
166 RANK = CEILING( ( N * REAL( RANKVAL( IRANK ) ) )
167 $ / 100.E+0 )
168 *
169 *
170 * Do first for UPLO = 'U', then for UPLO = 'L'
171 *
172 DO 120 IUPLO = 1, 2
173 UPLO = UPLOS( IUPLO )
174 *
175 * Set up parameters with SLATB5 and generate a test matrix
176 * with SLATMT.
177 *
178 CALL SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM,
179 $ MODE, CNDNUM, DIST )
180 *
181 SRNAMT = 'SLATMT'
182 CALL SLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE,
183 $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A,
184 $ LDA, WORK, INFO )
185 *
186 * Check error code from SLATMT.
187 *
188 IF( INFO.NE.0 ) THEN
189 CALL ALAERH( PATH, 'SLATMT', INFO, 0, UPLO, N,
190 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
191 $ NOUT )
192 GO TO 120
193 END IF
194 *
195 * Do for each value of NB in NBVAL
196 *
197 DO 110 INB = 1, NNB
198 NB = NBVAL( INB )
199 CALL XLAENV( 1, NB )
200 *
201 * Compute the pivoted L*L' or U'*U factorization
202 * of the matrix.
203 *
204 CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
205 SRNAMT = 'SPSTRF'
206 *
207 * Use default tolerance
208 *
209 TOL = -ONE
210 CALL SPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK,
211 $ TOL, WORK, INFO )
212 *
213 * Check error code from SPSTRF.
214 *
215 IF( (INFO.LT.IZERO)
216 $ .OR.(INFO.NE.IZERO.AND.RANK.EQ.N)
217 $ .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN
218 CALL ALAERH( PATH, 'SPSTRF', INFO, IZERO,
219 $ UPLO, N, N, -1, -1, NB, IMAT,
220 $ NFAIL, NERRS, NOUT )
221 GO TO 110
222 END IF
223 *
224 * Skip the test if INFO is not 0.
225 *
226 IF( INFO.NE.0 )
227 $ GO TO 110
228 *
229 * Reconstruct matrix from factors and compute residual.
230 *
231 * PERM holds permuted L*L^T or U^T*U
232 *
233 CALL SPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA,
234 $ PIV, RWORK, RESULT, COMPRANK )
235 *
236 * Print information about the tests that did not pass
237 * the threshold or where computed rank was not RANK.
238 *
239 IF( N.EQ.0 )
240 $ COMPRANK = 0
241 RANKDIFF = RANK - COMPRANK
242 IF( RESULT.GE.THRESH ) THEN
243 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
244 $ CALL ALAHD( NOUT, PATH )
245 WRITE( NOUT, FMT = 9999 )UPLO, N, RANK,
246 $ RANKDIFF, NB, IMAT, RESULT
247 NFAIL = NFAIL + 1
248 END IF
249 NRUN = NRUN + 1
250 110 CONTINUE
251 *
252 120 CONTINUE
253 130 CONTINUE
254 140 CONTINUE
255 150 CONTINUE
256 *
257 * Print a summary of the results.
258 *
259 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
260 *
261 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3,
262 $ ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =',
263 $ G12.5 )
264 RETURN
265 *
266 * End of SCHKPS
267 *
268 END
2 $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK,
3 $ RWORK, NOUT )
4 *
5 * -- LAPACK test routine (version 3.1) --
6 * Craig Lucas, University of Manchester / NAG Ltd.
7 * October, 2008
8 *
9 * .. Scalar Arguments ..
10 REAL THRESH
11 INTEGER NMAX, NN, NNB, NOUT, NRANK
12 LOGICAL TSTERR
13 * ..
14 * .. Array Arguments ..
15 REAL A( * ), AFAC( * ), PERM( * ), RWORK( * ),
16 $ WORK( * )
17 INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
18 LOGICAL DOTYPE( * )
19 * ..
20 *
21 * Purpose
22 * =======
23 *
24 * SCHKPS tests SPSTRF.
25 *
26 * Arguments
27 * =========
28 *
29 * DOTYPE (input) LOGICAL array, dimension (NTYPES)
30 * The matrix types to be used for testing. Matrices of type j
31 * (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
32 * .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
33 *
34 * NN (input) INTEGER
35 * The number of values of N contained in the vector NVAL.
36 *
37 * NVAL (input) INTEGER array, dimension (NN)
38 * The values of the matrix dimension N.
39 *
40 * NNB (input) INTEGER
41 * The number of values of NB contained in the vector NBVAL.
42 *
43 * NBVAL (input) INTEGER array, dimension (NBVAL)
44 * The values of the block size NB.
45 *
46 * NRANK (input) INTEGER
47 * The number of values of RANK contained in the vector RANKVAL.
48 *
49 * RANKVAL (input) INTEGER array, dimension (NBVAL)
50 * The values of the block size NB.
51 *
52 * THRESH (input) REAL
53 * The threshold value for the test ratios. A result is
54 * included in the output file if RESULT >= THRESH. To have
55 * every test ratio printed, use THRESH = 0.
56 *
57 * TSTERR (input) LOGICAL
58 * Flag that indicates whether error exits are to be tested.
59 *
60 * NMAX (input) INTEGER
61 * The maximum value permitted for N, used in dimensioning the
62 * work arrays.
63 *
64 * A (workspace) REAL array, dimension (NMAX*NMAX)
65 *
66 * AFAC (workspace) REAL array, dimension (NMAX*NMAX)
67 *
68 * PERM (workspace) REAL array, dimension (NMAX*NMAX)
69 *
70 * PIV (workspace) INTEGER array, dimension (NMAX)
71 *
72 * WORK (workspace) REAL array, dimension (NMAX*3)
73 *
74 * RWORK (workspace) REAL array, dimension (NMAX)
75 *
76 * NOUT (input) INTEGER
77 * The unit number for output.
78 *
79 * =====================================================================
80 *
81 * .. Parameters ..
82 REAL ONE
83 PARAMETER ( ONE = 1.0E+0 )
84 INTEGER NTYPES
85 PARAMETER ( NTYPES = 9 )
86 * ..
87 * .. Local Scalars ..
88 REAL ANORM, CNDNUM, RESULT, TOL
89 INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO,
90 $ IZERO, KL, KU, LDA, MODE, N, NB, NERRS, NFAIL,
91 $ NIMAT, NRUN, RANK, RANKDIFF
92 CHARACTER DIST, TYPE, UPLO
93 CHARACTER*3 PATH
94 * ..
95 * .. Local Arrays ..
96 INTEGER ISEED( 4 ), ISEEDY( 4 )
97 CHARACTER UPLOS( 2 )
98 * ..
99 * .. External Subroutines ..
100 EXTERNAL ALAERH, ALAHD, ALASUM, SERRPS, SLACPY, SLATB5,
101 $ SLATMT, SPST01, SPSTRF, XLAENV
102 * ..
103 * .. Scalars in Common ..
104 INTEGER INFOT, NUNIT
105 LOGICAL LERR, OK
106 CHARACTER*32 SRNAMT
107 * ..
108 * .. Common blocks ..
109 COMMON / INFOC / INFOT, NUNIT, OK, LERR
110 COMMON / SRNAMC / SRNAMT
111 * ..
112 * .. Intrinsic Functions ..
113 INTRINSIC MAX, REAL, CEILING
114 * ..
115 * .. Data statements ..
116 DATA ISEEDY / 1988, 1989, 1990, 1991 /
117 DATA UPLOS / 'U', 'L' /
118 * ..
119 * .. Executable Statements ..
120 *
121 * Initialize constants and the random number seed.
122 *
123 PATH( 1: 1 ) = 'Single Precision'
124 PATH( 2: 3 ) = 'PS'
125 NRUN = 0
126 NFAIL = 0
127 NERRS = 0
128 DO 100 I = 1, 4
129 ISEED( I ) = ISEEDY( I )
130 100 CONTINUE
131 *
132 * Test the error exits
133 *
134 IF( TSTERR )
135 $ CALL SERRPS( PATH, NOUT )
136 INFOT = 0
137 CALL XLAENV( 2, 2 )
138 *
139 * Do for each value of N in NVAL
140 *
141 DO 150 IN = 1, NN
142 N = NVAL( IN )
143 LDA = MAX( N, 1 )
144 NIMAT = NTYPES
145 IF( N.LE.0 )
146 $ NIMAT = 1
147 *
148 IZERO = 0
149 DO 140 IMAT = 1, NIMAT
150 *
151 * Do the tests only if DOTYPE( IMAT ) is true.
152 *
153 IF( .NOT.DOTYPE( IMAT ) )
154 $ GO TO 140
155 *
156 * Do for each value of RANK in RANKVAL
157 *
158 DO 130 IRANK = 1, NRANK
159 *
160 * Only repeat test 3 to 5 for different ranks
161 * Other tests use full rank
162 *
163 IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 )
164 $ GO TO 130
165 *
166 RANK = CEILING( ( N * REAL( RANKVAL( IRANK ) ) )
167 $ / 100.E+0 )
168 *
169 *
170 * Do first for UPLO = 'U', then for UPLO = 'L'
171 *
172 DO 120 IUPLO = 1, 2
173 UPLO = UPLOS( IUPLO )
174 *
175 * Set up parameters with SLATB5 and generate a test matrix
176 * with SLATMT.
177 *
178 CALL SLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM,
179 $ MODE, CNDNUM, DIST )
180 *
181 SRNAMT = 'SLATMT'
182 CALL SLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE,
183 $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A,
184 $ LDA, WORK, INFO )
185 *
186 * Check error code from SLATMT.
187 *
188 IF( INFO.NE.0 ) THEN
189 CALL ALAERH( PATH, 'SLATMT', INFO, 0, UPLO, N,
190 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
191 $ NOUT )
192 GO TO 120
193 END IF
194 *
195 * Do for each value of NB in NBVAL
196 *
197 DO 110 INB = 1, NNB
198 NB = NBVAL( INB )
199 CALL XLAENV( 1, NB )
200 *
201 * Compute the pivoted L*L' or U'*U factorization
202 * of the matrix.
203 *
204 CALL SLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
205 SRNAMT = 'SPSTRF'
206 *
207 * Use default tolerance
208 *
209 TOL = -ONE
210 CALL SPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK,
211 $ TOL, WORK, INFO )
212 *
213 * Check error code from SPSTRF.
214 *
215 IF( (INFO.LT.IZERO)
216 $ .OR.(INFO.NE.IZERO.AND.RANK.EQ.N)
217 $ .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN
218 CALL ALAERH( PATH, 'SPSTRF', INFO, IZERO,
219 $ UPLO, N, N, -1, -1, NB, IMAT,
220 $ NFAIL, NERRS, NOUT )
221 GO TO 110
222 END IF
223 *
224 * Skip the test if INFO is not 0.
225 *
226 IF( INFO.NE.0 )
227 $ GO TO 110
228 *
229 * Reconstruct matrix from factors and compute residual.
230 *
231 * PERM holds permuted L*L^T or U^T*U
232 *
233 CALL SPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA,
234 $ PIV, RWORK, RESULT, COMPRANK )
235 *
236 * Print information about the tests that did not pass
237 * the threshold or where computed rank was not RANK.
238 *
239 IF( N.EQ.0 )
240 $ COMPRANK = 0
241 RANKDIFF = RANK - COMPRANK
242 IF( RESULT.GE.THRESH ) THEN
243 IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
244 $ CALL ALAHD( NOUT, PATH )
245 WRITE( NOUT, FMT = 9999 )UPLO, N, RANK,
246 $ RANKDIFF, NB, IMAT, RESULT
247 NFAIL = NFAIL + 1
248 END IF
249 NRUN = NRUN + 1
250 110 CONTINUE
251 *
252 120 CONTINUE
253 130 CONTINUE
254 140 CONTINUE
255 150 CONTINUE
256 *
257 * Print a summary of the results.
258 *
259 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
260 *
261 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3,
262 $ ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =',
263 $ G12.5 )
264 RETURN
265 *
266 * End of SCHKPS
267 *
268 END