OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zchkps.f
Go to the documentation of this file.
1*> \brief \b ZCHKPS
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* SUBROUTINE ZCHKPS( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL,
12* THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK,
13* RWORK, NOUT )
14*
15* .. Scalar Arguments ..
16* DOUBLE PRECISION THRESH
17* INTEGER NMAX, NN, NNB, NOUT, NRANK
18* LOGICAL TSTERR
19* ..
20* .. Array Arguments ..
21* COMPLEX*16 A( * ), AFAC( * ), PERM( * ), WORK( * )
22* DOUBLE PRECISION RWORK( * )
23* INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
24* LOGICAL DOTYPE( * )
25* ..
26*
27*
28*> \par Purpose:
29* =============
30*>
31*> \verbatim
32*>
33*> ZCHKPS tests ZPSTRF.
34*> \endverbatim
35*
36* Arguments:
37* ==========
38*
39*> \param[in] DOTYPE
40*> \verbatim
41*> DOTYPE is LOGICAL array, dimension (NTYPES)
42*> The matrix types to be used for testing. Matrices of type j
43*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
44*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
45*> \endverbatim
46*>
47*> \param[in] NN
48*> \verbatim
49*> NN is INTEGER
50*> The number of values of N contained in the vector NVAL.
51*> \endverbatim
52*>
53*> \param[in] NVAL
54*> \verbatim
55*> NVAL is INTEGER array, dimension (NN)
56*> The values of the matrix dimension N.
57*> \endverbatim
58*>
59*> \param[in] NNB
60*> \verbatim
61*> NNB is INTEGER
62*> The number of values of NB contained in the vector NBVAL.
63*> \endverbatim
64*>
65*> \param[in] NBVAL
66*> \verbatim
67*> NBVAL is INTEGER array, dimension (NNB)
68*> The values of the block size NB.
69*> \endverbatim
70*>
71*> \param[in] NRANK
72*> \verbatim
73*> NRANK is INTEGER
74*> The number of values of RANK contained in the vector RANKVAL.
75*> \endverbatim
76*>
77*> \param[in] RANKVAL
78*> \verbatim
79*> RANKVAL is INTEGER array, dimension (NBVAL)
80*> The values of the block size NB.
81*> \endverbatim
82*>
83*> \param[in] THRESH
84*> \verbatim
85*> THRESH is DOUBLE PRECISION
86*> The threshold value for the test ratios. A result is
87*> included in the output file if RESULT >= THRESH. To have
88*> every test ratio printed, use THRESH = 0.
89*> \endverbatim
90*>
91*> \param[in] TSTERR
92*> \verbatim
93*> TSTERR is LOGICAL
94*> Flag that indicates whether error exits are to be tested.
95*> \endverbatim
96*>
97*> \param[in] NMAX
98*> \verbatim
99*> NMAX is INTEGER
100*> The maximum value permitted for N, used in dimensioning the
101*> work arrays.
102*> \endverbatim
103*>
104*> \param[out] A
105*> \verbatim
106*> A is COMPLEX*16 array, dimension (NMAX*NMAX)
107*> \endverbatim
108*>
109*> \param[out] AFAC
110*> \verbatim
111*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
112*> \endverbatim
113*>
114*> \param[out] PERM
115*> \verbatim
116*> PERM is COMPLEX*16 array, dimension (NMAX*NMAX)
117*> \endverbatim
118*>
119*> \param[out] PIV
120*> \verbatim
121*> PIV is INTEGER array, dimension (NMAX)
122*> \endverbatim
123*>
124*> \param[out] WORK
125*> \verbatim
126*> WORK is COMPLEX*16 array, dimension (NMAX*3)
127*> \endverbatim
128*>
129*> \param[out] RWORK
130*> \verbatim
131*> RWORK is DOUBLE PRECISION array, dimension (NMAX)
132*> \endverbatim
133*>
134*> \param[in] NOUT
135*> \verbatim
136*> NOUT is INTEGER
137*> The unit number for output.
138*> \endverbatim
139*
140* Authors:
141* ========
142*
143*> \author Univ. of Tennessee
144*> \author Univ. of California Berkeley
145*> \author Univ. of Colorado Denver
146*> \author NAG Ltd.
147*
148*> \ingroup complex16_lin
149*
150* =====================================================================
151 SUBROUTINE zchkps( DOTYPE, NN, NVAL, NNB, NBVAL, NRANK, RANKVAL,
152 $ THRESH, TSTERR, NMAX, A, AFAC, PERM, PIV, WORK,
153 $ RWORK, NOUT )
154*
155* -- LAPACK test routine --
156* -- LAPACK is a software package provided by Univ. of Tennessee, --
157* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
158*
159* .. Scalar Arguments ..
160 DOUBLE PRECISION THRESH
161 INTEGER NMAX, NN, NNB, NOUT, NRANK
162 LOGICAL TSTERR
163* ..
164* .. Array Arguments ..
165 COMPLEX*16 A( * ), AFAC( * ), PERM( * ), WORK( * )
166 DOUBLE PRECISION RWORK( * )
167 INTEGER NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
168 LOGICAL DOTYPE( * )
169* ..
170*
171* =====================================================================
172*
173* .. Parameters ..
174 DOUBLE PRECISION ONE
175 PARAMETER ( ONE = 1.0e+0 )
176 INTEGER NTYPES
177 parameter( ntypes = 9 )
178* ..
179* .. Local Scalars ..
180 DOUBLE PRECISION ANORM, CNDNUM, RESULT, TOL
181 INTEGER COMPRANK, I, IMAT, IN, INB, INFO, IRANK, IUPLO,
182 $ izero, kl, ku, lda, mode, n, nb, nerrs, nfail,
183 $ nimat, nrun, rank, rankdiff
184 CHARACTER DIST, TYPE, UPLO
185 CHARACTER*3 PATH
186* ..
187* .. Local Arrays ..
188 INTEGER ISEED( 4 ), ISEEDY( 4 )
189 CHARACTER UPLOS( 2 )
190* ..
191* .. External Subroutines ..
192 EXTERNAL alaerh, alahd, alasum, xlaenv, zerrps, zlacpy,
193 $ zlatb5, zlatmt, zpst01, zpstrf
194* ..
195* .. Scalars in Common ..
196 INTEGER INFOT, NUNIT
197 LOGICAL LERR, OK
198 CHARACTER*32 SRNAMT
199* ..
200* .. Common blocks ..
201 COMMON / infoc / infot, nunit, ok, lerr
202 COMMON / srnamc / srnamt
203* ..
204* .. Intrinsic Functions ..
205 INTRINSIC dble, max, ceiling
206* ..
207* .. Data statements ..
208 DATA iseedy / 1988, 1989, 1990, 1991 /
209 DATA uplos / 'U', 'L' /
210* ..
211* .. Executable Statements ..
212*
213* Initialize constants and the random number seed.
214*
215 path( 1: 1 ) = 'zomplex precision'
216 PATH( 2: 3 ) = 'ps'
217 NRUN = 0
218 NFAIL = 0
219 NERRS = 0
220 DO 100 I = 1, 4
221 ISEED( I ) = ISEEDY( I )
222 100 CONTINUE
223*
224* Test the error exits
225*
226 IF( TSTERR )
227 $ CALL ZERRPS( PATH, NOUT )
228 INFOT = 0
229*
230* Do for each value of N in NVAL
231*
232 DO 150 IN = 1, NN
233 N = NVAL( IN )
234 LDA = MAX( N, 1 )
235 NIMAT = NTYPES
236.LE. IF( N0 )
237 $ NIMAT = 1
238*
239 IZERO = 0
240 DO 140 IMAT = 1, NIMAT
241*
242* Do the tests only if DOTYPE( IMAT ) is true.
243*
244.NOT. IF( DOTYPE( IMAT ) )
245 $ GO TO 140
246*
247* Do for each value of RANK in RANKVAL
248*
249 DO 130 IRANK = 1, NRANK
250*
251* Only repeat test 3 to 5 for different ranks
252* Other tests use full rank
253*
254.LT..OR..GT..AND..GT. IF( ( IMAT3 IMAT5 ) IRANK1 )
255 $ GO TO 130
256*
257 RANK = CEILING( ( N * DBLE( RANKVAL( IRANK ) ) )
258 $ / 100.E+0 )
259*
260*
261* Do first for UPLO = 'U', then for UPLO = 'L'
262*
263 DO 120 IUPLO = 1, 2
264 UPLO = UPLOS( IUPLO )
265*
266* Set up parameters with ZLATB5 and generate a test matrix
267* with ZLATMT.
268*
269 CALL ZLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM,
270 $ MODE, CNDNUM, DIST )
271*
272 SRNAMT = 'zlatmt'
273 CALL ZLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE,
274 $ CNDNUM, ANORM, RANK, KL, KU, UPLO, A,
275 $ LDA, WORK, INFO )
276*
277* Check error code from ZLATMT.
278*
279.NE. IF( INFO0 ) THEN
280 CALL ALAERH( PATH, 'zlatmt', INFO, 0, UPLO, N,
281 $ N, -1, -1, -1, IMAT, NFAIL, NERRS,
282 $ NOUT )
283 GO TO 120
284 END IF
285*
286* Do for each value of NB in NBVAL
287*
288 DO 110 INB = 1, NNB
289 NB = NBVAL( INB )
290 CALL XLAENV( 1, NB )
291*
292* Compute the pivoted L*L' or U'*U factorization
293* of the matrix.
294*
295 CALL ZLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
296 SRNAMT = 'zpstrf'
297*
298* Use default tolerance
299*
300 TOL = -ONE
301 CALL ZPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK,
302 $ TOL, RWORK, INFO )
303*
304* Check error code from ZPSTRF.
305*
306.LT. IF( (INFOIZERO)
307.OR..NE..AND..EQ. $ (INFOIZERORANKN)
308.OR..LE..AND..LT. $ (INFOIZERORANKN) ) THEN
309 CALL ALAERH( PATH, 'zpstrf', INFO, IZERO,
310 $ UPLO, N, N, -1, -1, NB, IMAT,
311 $ NFAIL, NERRS, NOUT )
312 GO TO 110
313 END IF
314*
315* Skip the test if INFO is not 0.
316*
317.NE. IF( INFO0 )
318 $ GO TO 110
319*
320* Reconstruct matrix from factors and compute residual.
321*
322* PERM holds permuted L*L^T or U^T*U
323*
324 CALL ZPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA,
325 $ PIV, RWORK, RESULT, COMPRANK )
326*
327* Print information about the tests that did not pass
328* the threshold or where computed rank was not RANK.
329*
330.EQ. IF( N0 )
331 $ COMPRANK = 0
332 RANKDIFF = RANK - COMPRANK
333.GE. IF( RESULTTHRESH ) THEN
334.EQ..AND..EQ. IF( NFAIL0 NERRS0 )
335 $ CALL ALAHD( NOUT, PATH )
336 WRITE( NOUT, FMT = 9999 )UPLO, N, RANK,
337 $ RANKDIFF, NB, IMAT, RESULT
338 NFAIL = NFAIL + 1
339 END IF
340 NRUN = NRUN + 1
341 110 CONTINUE
342*
343 120 CONTINUE
344 130 CONTINUE
345 140 CONTINUE
346 150 CONTINUE
347*
348* Print a summary of the results.
349*
350 CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
351*
352 9999 FORMAT( ' uplo = ''', A1, ''', n =', I5, ', rank =', I3,
353 $ ', diff =', I5, ', nb =', I4, ', type ', I2, ', ratio =',
354 $ G12.5 )
355 RETURN
356*
357* End of ZCHKPS
358*
359 END
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alasum
subroutine alasum(type, nout, nfail, nrun, nerrs)
ALASUM
Definition alasum.f:73
alahd
subroutine alahd(iounit, path)
ALAHD
Definition alahd.f:107
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
zlacpy
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
Definition zlacpy.f:103
zpstrf
subroutine zpstrf(uplo, n, a, lda, piv, rank, tol, work, info)
ZPSTRF computes the Cholesky factorization with complete pivoting of a complex Hermitian positive sem...
Definition zpstrf.f:142
zerrps
subroutine zerrps(path, nunit)
ZERRPS
Definition zerrps.f:55
zlatb5
subroutine zlatb5(path, imat, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB5
Definition zlatb5.f:114
zpst01
subroutine zpst01(uplo, n, a, lda, afac, ldafac, perm, ldperm, piv, rwork, resid, rank)
ZPST01
Definition zpst01.f:136
zchkps
subroutine zchkps(dotype, nn, nval, nnb, nbval, nrank, rankval, thresh, tsterr, nmax, a, afac, perm, piv, work, rwork, nout)
ZCHKPS
Definition zchkps.f:154
zlatmt
subroutine zlatmt(m, n, dist, iseed, sym, d, mode, cond, dmax, rank, kl, ku, pack, a, lda, work, info)
ZLATMT
Definition zlatmt.f:340
max
#define max(a, b)
Definition macros.h:21