1*> \brief \b DCHKPS
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 DCHKPS( 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*       DOUBLE PRECISION   A( * ), AFAC( * ), PERM( * ), RWORK( * ),
22*      $                   WORK( * )
23*       INTEGER            NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
24*       LOGICAL            DOTYPE( * )
25*       ..
26*
27*
28*> \par Purpose:
29*  =============
30*>
31*> \verbatim
32*>
33*> DCHKPS tests DPSTRF.
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 DOUBLE PRECISION array, dimension (NMAX*NMAX)
107*> \endverbatim
108*>
109*> \param[out] AFAC
110*> \verbatim
111*>          AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
112*> \endverbatim
113*>
114*> \param[out] PERM
115*> \verbatim
116*>          PERM is DOUBLE PRECISION 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 DOUBLE PRECISION 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 double_lin
149*
150*  =====================================================================
151      SUBROUTINE DCHKPS( 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      DOUBLE PRECISION   A( * ), AFAC( * ), PERM( * ), RWORK( * ),
166     $                   WORK( * )
167      INTEGER            NBVAL( * ), NVAL( * ), PIV( * ), RANKVAL( * )
168      LOGICAL            DOTYPE( * )
169*     ..
170*
171*  =====================================================================
172*
173*     .. Parameters ..
174      DOUBLE PRECISION   ONE
175      PARAMETER          ( ONE = 1.0D+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, DERRPS, DLACPY, DLATB5,
193     $                   DLATMT, DPST01, DPSTRF, XLAENV
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 ) = 'Double 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 DERRPS( PATH, NOUT )
228      INFOT = 0
229      CALL XLAENV( 2, 2 )
230*
231*     Do for each value of N in NVAL
232*
233      DO 150 IN = 1, NN
234         N = NVAL( IN )
235         LDA = MAX( N, 1 )
236         NIMAT = NTYPES
237         IF( N.LE.0 )
238     $      NIMAT = 1
239*
240         IZERO = 0
241         DO 140 IMAT = 1, NIMAT
242*
243*           Do the tests only if DOTYPE( IMAT ) is true.
244*
245            IF( .NOT.DOTYPE( IMAT ) )
246     $         GO TO 140
247*
248*              Do for each value of RANK in RANKVAL
249*
250            DO 130 IRANK = 1, NRANK
251*
252*              Only repeat test 3 to 5 for different ranks
253*              Other tests use full rank
254*
255               IF( ( IMAT.LT.3 .OR. IMAT.GT.5 ) .AND. IRANK.GT.1 )
256     $            GO TO 130
257*
258               RANK = CEILING( ( N * DBLE( RANKVAL( IRANK ) ) )
259     $              / 100.D+0 )
260*
261*
262*           Do first for UPLO = 'U', then for UPLO = 'L'
263*
264               DO 120 IUPLO = 1, 2
265                  UPLO = UPLOS( IUPLO )
266*
267*              Set up parameters with DLATB5 and generate a test matrix
268*              with DLATMT.
269*
270                  CALL DLATB5( PATH, IMAT, N, TYPE, KL, KU, ANORM,
271     $                         MODE, CNDNUM, DIST )
272*
273                  SRNAMT = 'DLATMT'
274                  CALL DLATMT( N, N, DIST, ISEED, TYPE, RWORK, MODE,
275     $                         CNDNUM, ANORM, RANK, KL, KU, UPLO, A,
276     $                         LDA, WORK, INFO )
277*
278*              Check error code from DLATMT.
279*
280                  IF( INFO.NE.0 ) THEN
281                    CALL ALAERH( PATH, 'DLATMT', INFO, 0, UPLO, N,
282     $                           N, -1, -1, -1, IMAT, NFAIL, NERRS,
283     $                           NOUT )
284                     GO TO 120
285                  END IF
286*
287*              Do for each value of NB in NBVAL
288*
289                  DO 110 INB = 1, NNB
290                     NB = NBVAL( INB )
291                     CALL XLAENV( 1, NB )
292*
293*                 Compute the pivoted L*L' or U'*U factorization
294*                 of the matrix.
295*
296                     CALL DLACPY( UPLO, N, N, A, LDA, AFAC, LDA )
297                     SRNAMT = 'DPSTRF'
298*
299*                 Use default tolerance
300*
301                     TOL = -ONE
302                     CALL DPSTRF( UPLO, N, AFAC, LDA, PIV, COMPRANK,
303     $                            TOL, WORK, INFO )
304*
305*                 Check error code from DPSTRF.
306*
307                     IF( (INFO.LT.IZERO)
308     $                    .OR.(INFO.NE.IZERO.AND.RANK.EQ.N)
309     $                    .OR.(INFO.LE.IZERO.AND.RANK.LT.N) ) THEN
310                        CALL ALAERH( PATH, 'DPSTRF', INFO, IZERO,
311     $                               UPLO, N, N, -1, -1, NB, IMAT,
312     $                               NFAIL, NERRS, NOUT )
313                        GO TO 110
314                     END IF
315*
316*                 Skip the test if INFO is not 0.
317*
318                     IF( INFO.NE.0 )
319     $                  GO TO 110
320*
321*                 Reconstruct matrix from factors and compute residual.
322*
323*                 PERM holds permuted L*L^T or U^T*U
324*
325                     CALL DPST01( UPLO, N, A, LDA, AFAC, LDA, PERM, LDA,
326     $                            PIV, RWORK, RESULT, COMPRANK )
327*
328*                 Print information about the tests that did not pass
329*                 the threshold or where computed rank was not RANK.
330*
331                     IF( N.EQ.0 )
332     $                  COMPRANK = 0
333                     RANKDIFF = RANK - COMPRANK
334                     IF( RESULT.GE.THRESH ) THEN
335                        IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
336     $                     CALL ALAHD( NOUT, PATH )
337                        WRITE( NOUT, FMT = 9999 )UPLO, N, RANK,
338     $                     RANKDIFF, NB, IMAT, RESULT
339                        NFAIL = NFAIL + 1
340                     END IF
341                     NRUN = NRUN + 1
342  110             CONTINUE
343*
344  120          CONTINUE
345  130       CONTINUE
346  140    CONTINUE
347  150 CONTINUE
348*
349*     Print a summary of the results.
350*
351      CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
352*
353 9999 FORMAT( ' UPLO = ''', A1, ''', N =', I5, ', RANK =', I3,
354     $      ', Diff =', I5, ', NB =', I4, ', type ', I2, ', Ratio =',
355     $      G12.5 )
356      RETURN
357*
358*     End of DCHKPS
359*
360      END
361