1*> \brief \b DDRVAC
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 DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX,
12*                          A, AFAC, B, X, WORK,
13*                          RWORK, SWORK, NOUT )
14*
15*       .. Scalar Arguments ..
16*       INTEGER            NMAX, NM, NNS, NOUT
17*       DOUBLE PRECISION   THRESH
18*       ..
19*       .. Array Arguments ..
20*       LOGICAL            DOTYPE( * )
21*       INTEGER            MVAL( * ), NSVAL( * )
22*       REAL               SWORK(*)
23*       DOUBLE PRECISION   A( * ), AFAC( * ), B( * ),
24*      $                   RWORK( * ), WORK( * ), X( * )
25*       ..
26*
27*
28*> \par Purpose:
29*  =============
30*>
31*> \verbatim
32*>
33*> DDRVAC tests DSPOSV.
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] NM
48*> \verbatim
49*>          NM is INTEGER
50*>          The number of values of N contained in the vector MVAL.
51*> \endverbatim
52*>
53*> \param[in] MVAL
54*> \verbatim
55*>          MVAL is INTEGER array, dimension (NM)
56*>          The values of the matrix dimension N.
57*> \endverbatim
58*>
59*> \param[in] NNS
60*> \verbatim
61*>          NNS is INTEGER
62*>          The number of values of NRHS contained in the vector NSVAL.
63*> \endverbatim
64*>
65*> \param[in] NSVAL
66*> \verbatim
67*>          NSVAL is INTEGER array, dimension (NNS)
68*>          The values of the number of right hand sides NRHS.
69*> \endverbatim
70*>
71*> \param[in] THRESH
72*> \verbatim
73*>          THRESH is DOUBLE PRECISION
74*>          The threshold value for the test ratios.  A result is
75*>          included in the output file if RESULT >= THRESH.  To have
76*>          every test ratio printed, use THRESH = 0.
77*> \endverbatim
78*>
79*> \param[in] NMAX
80*> \verbatim
81*>          NMAX is INTEGER
82*>          The maximum value permitted for N, used in dimensioning the
83*>          work arrays.
84*> \endverbatim
85*>
86*> \param[out] A
87*> \verbatim
88*>          A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
89*> \endverbatim
90*>
91*> \param[out] AFAC
92*> \verbatim
93*>          AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
94*> \endverbatim
95*>
96*> \param[out] B
97*> \verbatim
98*>          B is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
99*> \endverbatim
100*>
101*> \param[out] X
102*> \verbatim
103*>          X is DOUBLE PRECISION array, dimension (NMAX*NSMAX)
104*> \endverbatim
105*>
106*> \param[out] WORK
107*> \verbatim
108*>          WORK is DOUBLE PRECISION array, dimension
109*>                      (NMAX*max(3,NSMAX))
110*> \endverbatim
111*>
112*> \param[out] RWORK
113*> \verbatim
114*>          RWORK is DOUBLE PRECISION array, dimension
115*>                      (max(2*NMAX,2*NSMAX+NWORK))
116*> \endverbatim
117*>
118*> \param[out] SWORK
119*> \verbatim
120*>          SWORK is REAL array, dimension
121*>                      (NMAX*(NSMAX+NMAX))
122*> \endverbatim
123*>
124*> \param[in] NOUT
125*> \verbatim
126*>          NOUT is INTEGER
127*>          The unit number for output.
128*> \endverbatim
129*
130*  Authors:
131*  ========
132*
133*> \author Univ. of Tennessee
134*> \author Univ. of California Berkeley
135*> \author Univ. of Colorado Denver
136*> \author NAG Ltd.
137*
138*> \date December 2016
139*
140*> \ingroup double_lin
141*
142*  =====================================================================
143      SUBROUTINE DDRVAC( DOTYPE, NM, MVAL, NNS, NSVAL, THRESH, NMAX,
144     $                   A, AFAC, B, X, WORK,
145     $                   RWORK, SWORK, NOUT )
146*
147*  -- LAPACK test routine (version 3.7.0) --
148*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
149*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
150*     December 2016
151*
152*     .. Scalar Arguments ..
153      INTEGER            NMAX, NM, NNS, NOUT
154      DOUBLE PRECISION   THRESH
155*     ..
156*     .. Array Arguments ..
157      LOGICAL            DOTYPE( * )
158      INTEGER            MVAL( * ), NSVAL( * )
159      REAL               SWORK(*)
160      DOUBLE PRECISION   A( * ), AFAC( * ), B( * ),
161     $                   RWORK( * ), WORK( * ), X( * )
162*     ..
163*
164*  =====================================================================
165*
166*     .. Parameters ..
167      DOUBLE PRECISION   ZERO
168      PARAMETER          ( ZERO = 0.0D+0 )
169      INTEGER            NTYPES
170      PARAMETER          ( NTYPES = 9 )
171      INTEGER            NTESTS
172      PARAMETER          ( NTESTS = 1 )
173*     ..
174*     .. Local Scalars ..
175      LOGICAL            ZEROT
176      CHARACTER          DIST, TYPE, UPLO, XTYPE
177      CHARACTER*3        PATH
178      INTEGER            I, IM, IMAT, INFO, IOFF, IRHS, IUPLO,
179     $                   IZERO, KL, KU, LDA, MODE, N,
180     $                   NERRS, NFAIL, NIMAT, NRHS, NRUN
181      DOUBLE PRECISION   ANORM, CNDNUM
182*     ..
183*     .. Local Arrays ..
184      CHARACTER          UPLOS( 2 )
185      INTEGER            ISEED( 4 ), ISEEDY( 4 )
186      DOUBLE PRECISION   RESULT( NTESTS )
187*     ..
188*     .. Local Variables ..
189      INTEGER            ITER, KASE
190*     ..
191*     .. External Functions ..
192      LOGICAL            LSAME
193      EXTERNAL           LSAME
194*     ..
195*     .. External Subroutines ..
196      EXTERNAL           ALAERH, DLACPY,
197     $                   DLARHS, DLASET, DLATB4, DLATMS,
198     $                   DPOT06, DSPOSV
199*     ..
200*     .. Intrinsic Functions ..
201      INTRINSIC          DBLE, MAX, SQRT
202*     ..
203*     .. Scalars in Common ..
204      LOGICAL            LERR, OK
205      CHARACTER*32       SRNAMT
206      INTEGER            INFOT, NUNIT
207*     ..
208*     .. Common blocks ..
209      COMMON             / INFOC / INFOT, NUNIT, OK, LERR
210      COMMON             / SRNAMC / SRNAMT
211*     ..
212*     .. Data statements ..
213      DATA               ISEEDY / 1988, 1989, 1990, 1991 /
214      DATA               UPLOS / 'U', 'L' /
215*     ..
216*     .. Executable Statements ..
217*
218*     Initialize constants and the random number seed.
219*
220      KASE = 0
221      PATH( 1: 1 ) = 'Double precision'
222      PATH( 2: 3 ) = 'PO'
223      NRUN = 0
224      NFAIL = 0
225      NERRS = 0
226      DO 10 I = 1, 4
227         ISEED( I ) = ISEEDY( I )
228   10 CONTINUE
229*
230      INFOT = 0
231*
232*     Do for each value of N in MVAL
233*
234      DO 120 IM = 1, NM
235         N = MVAL( IM )
236         LDA = MAX( N, 1 )
237         NIMAT = NTYPES
238         IF( N.LE.0 )
239     $      NIMAT = 1
240*
241         DO 110 IMAT = 1, NIMAT
242*
243*           Do the tests only if DOTYPE( IMAT ) is true.
244*
245            IF( .NOT.DOTYPE( IMAT ) )
246     $         GO TO 110
247*
248*           Skip types 3, 4, or 5 if the matrix size is too small.
249*
250            ZEROT = IMAT.GE.3 .AND. IMAT.LE.5
251            IF( ZEROT .AND. N.LT.IMAT-2 )
252     $         GO TO 110
253*
254*           Do first for UPLO = 'U', then for UPLO = 'L'
255*
256            DO 100 IUPLO = 1, 2
257               UPLO = UPLOS( IUPLO )
258*
259*              Set up parameters with DLATB4 and generate a test matrix
260*              with DLATMS.
261*
262               CALL DLATB4( PATH, IMAT, N, N, TYPE, KL, KU, ANORM, MODE,
263     $                      CNDNUM, DIST )
264*
265               SRNAMT = 'DLATMS'
266               CALL DLATMS( N, N, DIST, ISEED, TYPE, RWORK, MODE,
267     $                      CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
268     $                      INFO )
269*
270*              Check error code from DLATMS.
271*
272               IF( INFO.NE.0 ) THEN
273                  CALL ALAERH( PATH, 'DLATMS', INFO, 0, UPLO, N, N, -1,
274     $                         -1, -1, IMAT, NFAIL, NERRS, NOUT )
275                  GO TO 100
276               END IF
277*
278*              For types 3-5, zero one row and column of the matrix to
279*              test that INFO is returned correctly.
280*
281               IF( ZEROT ) THEN
282                  IF( IMAT.EQ.3 ) THEN
283                     IZERO = 1
284                  ELSE IF( IMAT.EQ.4 ) THEN
285                     IZERO = N
286                  ELSE
287                     IZERO = N / 2 + 1
288                  END IF
289                  IOFF = ( IZERO-1 )*LDA
290*
291*                 Set row and column IZERO of A to 0.
292*
293                  IF( IUPLO.EQ.1 ) THEN
294                     DO 20 I = 1, IZERO - 1
295                        A( IOFF+I ) = ZERO
296   20                CONTINUE
297                     IOFF = IOFF + IZERO
298                     DO 30 I = IZERO, N
299                        A( IOFF ) = ZERO
300                        IOFF = IOFF + LDA
301   30                CONTINUE
302                  ELSE
303                     IOFF = IZERO
304                     DO 40 I = 1, IZERO - 1
305                        A( IOFF ) = ZERO
306                        IOFF = IOFF + LDA
307   40                CONTINUE
308                     IOFF = IOFF - IZERO
309                     DO 50 I = IZERO, N
310                        A( IOFF+I ) = ZERO
311   50                CONTINUE
312                  END IF
313               ELSE
314                  IZERO = 0
315               END IF
316*
317               DO 60 IRHS = 1, NNS
318                  NRHS = NSVAL( IRHS )
319                  XTYPE = 'N'
320*
321*                 Form an exact solution and set the right hand side.
322*
323                  SRNAMT = 'DLARHS'
324                  CALL DLARHS( PATH, XTYPE, UPLO, ' ', N, N, KL, KU,
325     $                         NRHS, A, LDA, X, LDA, B, LDA,
326     $                         ISEED, INFO )
327*
328*                 Compute the L*L' or U'*U factorization of the
329*                 matrix and solve the system.
330*
331                  SRNAMT = 'DSPOSV '
332                  KASE = KASE + 1
333*
334                  CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA)
335*
336                  CALL DSPOSV( UPLO, N, NRHS, AFAC, LDA, B, LDA, X, LDA,
337     $                         WORK, SWORK, ITER, INFO )
338
339                  IF (ITER.LT.0) THEN
340                     CALL DLACPY( 'All', N, N, A, LDA, AFAC, LDA )
341                  ENDIF
342*
343*                 Check error code from DSPOSV .
344*
345                  IF( INFO.NE.IZERO ) THEN
346*
347                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
348     $                  CALL ALAHD( NOUT, PATH )
349                     NERRS = NERRS + 1
350*
351                     IF( INFO.NE.IZERO .AND. IZERO.NE.0 ) THEN
352                        WRITE( NOUT, FMT = 9988 )'DSPOSV',INFO,IZERO,N,
353     $                     IMAT
354                     ELSE
355                        WRITE( NOUT, FMT = 9975 )'DSPOSV',INFO,N,IMAT
356                     END IF
357                  END IF
358*
359*                 Skip the remaining test if the matrix is singular.
360*
361                  IF( INFO.NE.0 )
362     $               GO TO 110
363*
364*                 Check the quality of the solution
365*
366                  CALL DLACPY( 'All', N, NRHS, B, LDA, WORK, LDA )
367*
368                  CALL DPOT06( UPLO, N, NRHS, A, LDA, X, LDA, WORK,
369     $               LDA, RWORK, RESULT( 1 ) )
370*
371*                 Check if the test passes the tesing.
372*                 Print information about the tests that did not
373*                 pass the testing.
374*
375*                 If iterative refinement has been used and claimed to
376*                 be successful (ITER>0), we want
377*                 NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS*SRQT(N)) < 1
378*
379*                 If double precision has been used (ITER<0), we want
380*                 NORM1(B - A*X)/(NORM1(A)*NORM1(X)*EPS) < THRES
381*                 (Cf. the linear solver testing routines)
382*
383                  IF ((THRESH.LE.0.0E+00)
384     $               .OR.((ITER.GE.0).AND.(N.GT.0)
385     $               .AND.(RESULT(1).GE.SQRT(DBLE(N))))
386     $               .OR.((ITER.LT.0).AND.(RESULT(1).GE.THRESH))) THEN
387*
388                     IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
389                        WRITE( NOUT, FMT = 8999 )'DPO'
390                        WRITE( NOUT, FMT = '( '' Matrix types:'' )' )
391                        WRITE( NOUT, FMT = 8979 )
392                        WRITE( NOUT, FMT = '( '' Test ratios:'' )' )
393                        WRITE( NOUT, FMT = 8960 )1
394                        WRITE( NOUT, FMT = '( '' Messages:'' )' )
395                     END IF
396*
397                     WRITE( NOUT, FMT = 9998 )UPLO, N, NRHS, IMAT, 1,
398     $                  RESULT( 1 )
399*
400                     NFAIL = NFAIL + 1
401*
402                  END IF
403*
404                  NRUN = NRUN + 1
405*
406   60          CONTINUE
407  100       CONTINUE
408  110    CONTINUE
409  120 CONTINUE
410*
411*     Print a summary of the results.
412*
413      IF( NFAIL.GT.0 ) THEN
414         WRITE( NOUT, FMT = 9996 )'DSPOSV', NFAIL, NRUN
415      ELSE
416         WRITE( NOUT, FMT = 9995 )'DSPOSV', NRUN
417      END IF
418      IF( NERRS.GT.0 ) THEN
419         WRITE( NOUT, FMT = 9994 )NERRS
420      END IF
421*
422 9998 FORMAT( ' UPLO=''', A1, ''', N =', I5, ', NRHS=', I3, ', type ',
423     $      I2, ', test(', I2, ') =', G12.5 )
424 9996 FORMAT( 1X, A6, ': ', I6, ' out of ', I6,
425     $      ' tests failed to pass the threshold' )
426 9995 FORMAT( /1X, 'All tests for ', A6,
427     $      ' routines passed the threshold ( ', I6, ' tests run)' )
428 9994 FORMAT( 6X, I6, ' error messages recorded' )
429*
430*     SUBNAM, INFO, INFOE, N, IMAT
431*
432 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
433     $      I5, / ' ==> N =', I5, ', type ',
434     $      I2 )
435*
436*     SUBNAM, INFO, N, IMAT
437*
438 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5,
439     $      ', type ', I2 )
440 8999 FORMAT( / 1X, A3, ':  positive definite dense matrices' )
441 8979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X,
442     $      '2. Upper triangular', 16X,
443     $      '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
444     $      '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS',
445     $      / 4X, '4. Random, CNDNUM = 2', 13X,
446     $      '10. Scaled near underflow', / 4X, '5. First column zero',
447     $      14X, '11. Scaled near overflow', / 4X,
448     $      '6. Last column zero' )
449 8960 FORMAT( 3X, I2, ': norm_1( B - A * X )  / ',
450     $      '( norm_1(A) * norm_1(X) * EPS * SQRT(N) ) > 1 if ITERREF',
451     $      / 4x, 'or norm_1( B - A * X )  / ',
452     $      '( norm_1(A) * norm_1(X) * EPS ) > THRES if DPOTRF' )
453
454      RETURN
455*
456*     End of DDRVAC
457*
458      END
459