LAPACK 3.12.0
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ ddrvpo()

subroutine ddrvpo ( logical, dimension( * )  dotype,
integer  nn,
integer, dimension( * )  nval,
integer  nrhs,
double precision  thresh,
logical  tsterr,
integer  nmax,
double precision, dimension( * )  a,
double precision, dimension( * )  afac,
double precision, dimension( * )  asav,
double precision, dimension( * )  b,
double precision, dimension( * )  bsav,
double precision, dimension( * )  x,
double precision, dimension( * )  xact,
double precision, dimension( * )  s,
double precision, dimension( * )  work,
double precision, dimension( * )  rwork,
integer, dimension( * )  iwork,
integer  nout 
)

DDRVPO

Purpose:
 DDRVPO tests the driver routines DPOSV and -SVX.
Parameters
[in]DOTYPE
          DOTYPE is LOGICAL array, dimension (NTYPES)
          The matrix types to be used for testing.  Matrices of type j
          (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
          .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
[in]NN
          NN is INTEGER
          The number of values of N contained in the vector NVAL.
[in]NVAL
          NVAL is INTEGER array, dimension (NN)
          The values of the matrix dimension N.
[in]NRHS
          NRHS is INTEGER
          The number of right hand side vectors to be generated for
          each linear system.
[in]THRESH
          THRESH is DOUBLE PRECISION
          The threshold value for the test ratios.  A result is
          included in the output file if RESULT >= THRESH.  To have
          every test ratio printed, use THRESH = 0.
[in]TSTERR
          TSTERR is LOGICAL
          Flag that indicates whether error exits are to be tested.
[in]NMAX
          NMAX is INTEGER
          The maximum value permitted for N, used in dimensioning the
          work arrays.
[out]A
          A is DOUBLE PRECISION array, dimension (NMAX*NMAX)
[out]AFAC
          AFAC is DOUBLE PRECISION array, dimension (NMAX*NMAX)
[out]ASAV
          ASAV is DOUBLE PRECISION array, dimension (NMAX*NMAX)
[out]B
          B is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]BSAV
          BSAV is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]X
          X is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]XACT
          XACT is DOUBLE PRECISION array, dimension (NMAX*NRHS)
[out]S
          S is DOUBLE PRECISION array, dimension (NMAX)
[out]WORK
          WORK is DOUBLE PRECISION array, dimension
                      (NMAX*max(3,NRHS))
[out]RWORK
          RWORK is DOUBLE PRECISION array, dimension (NMAX+2*NRHS)
[out]IWORK
          IWORK is INTEGER array, dimension (NMAX)
[in]NOUT
          NOUT is INTEGER
          The unit number for output.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.

Definition at line 161 of file ddrvpo.f.

164*
165* -- LAPACK test routine --
166* -- LAPACK is a software package provided by Univ. of Tennessee, --
167* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
168*
169* .. Scalar Arguments ..
170 LOGICAL TSTERR
171 INTEGER NMAX, NN, NOUT, NRHS
172 DOUBLE PRECISION THRESH
173* ..
174* .. Array Arguments ..
175 LOGICAL DOTYPE( * )
176 INTEGER IWORK( * ), NVAL( * )
177 DOUBLE PRECISION A( * ), AFAC( * ), ASAV( * ), B( * ),
178 $ BSAV( * ), RWORK( * ), S( * ), WORK( * ),
179 $ X( * ), XACT( * )
180* ..
181*
182* =====================================================================
183*
184* .. Parameters ..
185 DOUBLE PRECISION ONE, ZERO
186 parameter( one = 1.0d+0, zero = 0.0d+0 )
187 INTEGER NTYPES
188 parameter( ntypes = 9 )
189 INTEGER NTESTS
190 parameter( ntests = 6 )
191* ..
192* .. Local Scalars ..
193 LOGICAL EQUIL, NOFACT, PREFAC, ZEROT
194 CHARACTER DIST, EQUED, FACT, TYPE, UPLO, XTYPE
195 CHARACTER*3 PATH
196 INTEGER I, IEQUED, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
197 $ IZERO, K, K1, KL, KU, LDA, MODE, N, NB, NBMIN,
198 $ NERRS, NFACT, NFAIL, NIMAT, NRUN, NT
199 DOUBLE PRECISION AINVNM, AMAX, ANORM, CNDNUM, RCOND, RCONDC,
200 $ ROLDC, SCOND
201* ..
202* .. Local Arrays ..
203 CHARACTER EQUEDS( 2 ), FACTS( 3 ), UPLOS( 2 )
204 INTEGER ISEED( 4 ), ISEEDY( 4 )
205 DOUBLE PRECISION RESULT( NTESTS )
206* ..
207* .. External Functions ..
208 LOGICAL LSAME
209 DOUBLE PRECISION DGET06, DLANSY
210 EXTERNAL lsame, dget06, dlansy
211* ..
212* .. External Subroutines ..
213 EXTERNAL aladhd, alaerh, alasvm, derrvx, dget04, dlacpy,
214 $ dlaqsy, dlarhs, dlaset, dlatb4, dlatms, dpoequ,
215 $ dposv, dposvx, dpot01, dpot02, dpot05, dpotrf,
216 $ dpotri, xlaenv
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC max
220* ..
221* .. Scalars in Common ..
222 LOGICAL LERR, OK
223 CHARACTER*32 SRNAMT
224 INTEGER INFOT, NUNIT
225* ..
226* .. Common blocks ..
227 COMMON / infoc / infot, nunit, ok, lerr
228 COMMON / srnamc / srnamt
229* ..
230* .. Data statements ..
231 DATA iseedy / 1988, 1989, 1990, 1991 /
232 DATA uplos / 'U', 'L' /
233 DATA facts / 'F', 'N', 'E' /
234 DATA equeds / 'N', 'Y' /
235* ..
236* .. Executable Statements ..
237*
238* Initialize constants and the random number seed.
239*
240 path( 1: 1 ) = 'Double precision'
241 path( 2: 3 ) = 'PO'
242 nrun = 0
243 nfail = 0
244 nerrs = 0
245 DO 10 i = 1, 4
246 iseed( i ) = iseedy( i )
247 10 CONTINUE
248*
249* Test the error exits
250*
251 IF( tsterr )
252 $ CALL derrvx( path, nout )
253 infot = 0
254*
255* Set the block size and minimum block size for testing.
256*
257 nb = 1
258 nbmin = 2
259 CALL xlaenv( 1, nb )
260 CALL xlaenv( 2, nbmin )
261*
262* Do for each value of N in NVAL
263*
264 DO 130 in = 1, nn
265 n = nval( in )
266 lda = max( n, 1 )
267 xtype = 'N'
268 nimat = ntypes
269 IF( n.LE.0 )
270 $ nimat = 1
271*
272 DO 120 imat = 1, nimat
273*
274* Do the tests only if DOTYPE( IMAT ) is true.
275*
276 IF( .NOT.dotype( imat ) )
277 $ GO TO 120
278*
279* Skip types 3, 4, or 5 if the matrix size is too small.
280*
281 zerot = imat.GE.3 .AND. imat.LE.5
282 IF( zerot .AND. n.LT.imat-2 )
283 $ GO TO 120
284*
285* Do first for UPLO = 'U', then for UPLO = 'L'
286*
287 DO 110 iuplo = 1, 2
288 uplo = uplos( iuplo )
289*
290* Set up parameters with DLATB4 and generate a test matrix
291* with DLATMS.
292*
293 CALL dlatb4( path, imat, n, n, TYPE, KL, KU, ANORM, MODE,
294 $ CNDNUM, DIST )
295*
296 srnamt = 'DLATMS'
297 CALL dlatms( n, n, dist, iseed, TYPE, RWORK, MODE,
298 $ CNDNUM, ANORM, KL, KU, UPLO, A, LDA, WORK,
299 $ INFO )
300*
301* Check error code from DLATMS.
302*
303 IF( info.NE.0 ) THEN
304 CALL alaerh( path, 'DLATMS', info, 0, uplo, n, n, -1,
305 $ -1, -1, imat, nfail, nerrs, nout )
306 GO TO 110
307 END IF
308*
309* For types 3-5, zero one row and column of the matrix to
310* test that INFO is returned correctly.
311*
312 IF( zerot ) THEN
313 IF( imat.EQ.3 ) THEN
314 izero = 1
315 ELSE IF( imat.EQ.4 ) THEN
316 izero = n
317 ELSE
318 izero = n / 2 + 1
319 END IF
320 ioff = ( izero-1 )*lda
321*
322* Set row and column IZERO of A to 0.
323*
324 IF( iuplo.EQ.1 ) THEN
325 DO 20 i = 1, izero - 1
326 a( ioff+i ) = zero
327 20 CONTINUE
328 ioff = ioff + izero
329 DO 30 i = izero, n
330 a( ioff ) = zero
331 ioff = ioff + lda
332 30 CONTINUE
333 ELSE
334 ioff = izero
335 DO 40 i = 1, izero - 1
336 a( ioff ) = zero
337 ioff = ioff + lda
338 40 CONTINUE
339 ioff = ioff - izero
340 DO 50 i = izero, n
341 a( ioff+i ) = zero
342 50 CONTINUE
343 END IF
344 ELSE
345 izero = 0
346 END IF
347*
348* Save a copy of the matrix A in ASAV.
349*
350 CALL dlacpy( uplo, n, n, a, lda, asav, lda )
351*
352 DO 100 iequed = 1, 2
353 equed = equeds( iequed )
354 IF( iequed.EQ.1 ) THEN
355 nfact = 3
356 ELSE
357 nfact = 1
358 END IF
359*
360 DO 90 ifact = 1, nfact
361 fact = facts( ifact )
362 prefac = lsame( fact, 'F' )
363 nofact = lsame( fact, 'N' )
364 equil = lsame( fact, 'E' )
365*
366 IF( zerot ) THEN
367 IF( prefac )
368 $ GO TO 90
369 rcondc = zero
370*
371 ELSE IF( .NOT.lsame( fact, 'N' ) ) THEN
372*
373* Compute the condition number for comparison with
374* the value returned by DPOSVX (FACT = 'N' reuses
375* the condition number from the previous iteration
376* with FACT = 'F').
377*
378 CALL dlacpy( uplo, n, n, asav, lda, afac, lda )
379 IF( equil .OR. iequed.GT.1 ) THEN
380*
381* Compute row and column scale factors to
382* equilibrate the matrix A.
383*
384 CALL dpoequ( n, afac, lda, s, scond, amax,
385 $ info )
386 IF( info.EQ.0 .AND. n.GT.0 ) THEN
387 IF( iequed.GT.1 )
388 $ scond = zero
389*
390* Equilibrate the matrix.
391*
392 CALL dlaqsy( uplo, n, afac, lda, s, scond,
393 $ amax, equed )
394 END IF
395 END IF
396*
397* Save the condition number of the
398* non-equilibrated system for use in DGET04.
399*
400 IF( equil )
401 $ roldc = rcondc
402*
403* Compute the 1-norm of A.
404*
405 anorm = dlansy( '1', uplo, n, afac, lda, rwork )
406*
407* Factor the matrix A.
408*
409 CALL dpotrf( uplo, n, afac, lda, info )
410*
411* Form the inverse of A.
412*
413 CALL dlacpy( uplo, n, n, afac, lda, a, lda )
414 CALL dpotri( uplo, n, a, lda, info )
415*
416* Compute the 1-norm condition number of A.
417*
418 ainvnm = dlansy( '1', uplo, n, a, lda, rwork )
419 IF( anorm.LE.zero .OR. ainvnm.LE.zero ) THEN
420 rcondc = one
421 ELSE
422 rcondc = ( one / anorm ) / ainvnm
423 END IF
424 END IF
425*
426* Restore the matrix A.
427*
428 CALL dlacpy( uplo, n, n, asav, lda, a, lda )
429*
430* Form an exact solution and set the right hand side.
431*
432 srnamt = 'DLARHS'
433 CALL dlarhs( path, xtype, uplo, ' ', n, n, kl, ku,
434 $ nrhs, a, lda, xact, lda, b, lda,
435 $ iseed, info )
436 xtype = 'C'
437 CALL dlacpy( 'Full', n, nrhs, b, lda, bsav, lda )
438*
439 IF( nofact ) THEN
440*
441* --- Test DPOSV ---
442*
443* Compute the L*L' or U'*U factorization of the
444* matrix and solve the system.
445*
446 CALL dlacpy( uplo, n, n, a, lda, afac, lda )
447 CALL dlacpy( 'Full', n, nrhs, b, lda, x, lda )
448*
449 srnamt = 'DPOSV '
450 CALL dposv( uplo, n, nrhs, afac, lda, x, lda,
451 $ info )
452*
453* Check error code from DPOSV .
454*
455 IF( info.NE.izero ) THEN
456 CALL alaerh( path, 'DPOSV ', info, izero,
457 $ uplo, n, n, -1, -1, nrhs, imat,
458 $ nfail, nerrs, nout )
459 GO TO 70
460 ELSE IF( info.NE.0 ) THEN
461 GO TO 70
462 END IF
463*
464* Reconstruct matrix from factors and compute
465* residual.
466*
467 CALL dpot01( uplo, n, a, lda, afac, lda, rwork,
468 $ result( 1 ) )
469*
470* Compute residual of the computed solution.
471*
472 CALL dlacpy( 'Full', n, nrhs, b, lda, work,
473 $ lda )
474 CALL dpot02( uplo, n, nrhs, a, lda, x, lda,
475 $ work, lda, rwork, result( 2 ) )
476*
477* Check solution from generated exact solution.
478*
479 CALL dget04( n, nrhs, x, lda, xact, lda, rcondc,
480 $ result( 3 ) )
481 nt = 3
482*
483* Print information about the tests that did not
484* pass the threshold.
485*
486 DO 60 k = 1, nt
487 IF( result( k ).GE.thresh ) THEN
488 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
489 $ CALL aladhd( nout, path )
490 WRITE( nout, fmt = 9999 )'DPOSV ', uplo,
491 $ n, imat, k, result( k )
492 nfail = nfail + 1
493 END IF
494 60 CONTINUE
495 nrun = nrun + nt
496 70 CONTINUE
497 END IF
498*
499* --- Test DPOSVX ---
500*
501 IF( .NOT.prefac )
502 $ CALL dlaset( uplo, n, n, zero, zero, afac, lda )
503 CALL dlaset( 'Full', n, nrhs, zero, zero, x, lda )
504 IF( iequed.GT.1 .AND. n.GT.0 ) THEN
505*
506* Equilibrate the matrix if FACT='F' and
507* EQUED='Y'.
508*
509 CALL dlaqsy( uplo, n, a, lda, s, scond, amax,
510 $ equed )
511 END IF
512*
513* Solve the system and compute the condition number
514* and error bounds using DPOSVX.
515*
516 srnamt = 'DPOSVX'
517 CALL dposvx( fact, uplo, n, nrhs, a, lda, afac,
518 $ lda, equed, s, b, lda, x, lda, rcond,
519 $ rwork, rwork( nrhs+1 ), work, iwork,
520 $ info )
521*
522* Check the error code from DPOSVX.
523*
524 IF( info.NE.izero ) THEN
525 CALL alaerh( path, 'DPOSVX', info, izero,
526 $ fact // uplo, n, n, -1, -1, nrhs,
527 $ imat, nfail, nerrs, nout )
528 GO TO 90
529 END IF
530*
531 IF( info.EQ.0 ) THEN
532 IF( .NOT.prefac ) THEN
533*
534* Reconstruct matrix from factors and compute
535* residual.
536*
537 CALL dpot01( uplo, n, a, lda, afac, lda,
538 $ rwork( 2*nrhs+1 ), result( 1 ) )
539 k1 = 1
540 ELSE
541 k1 = 2
542 END IF
543*
544* Compute residual of the computed solution.
545*
546 CALL dlacpy( 'Full', n, nrhs, bsav, lda, work,
547 $ lda )
548 CALL dpot02( uplo, n, nrhs, asav, lda, x, lda,
549 $ work, lda, rwork( 2*nrhs+1 ),
550 $ result( 2 ) )
551*
552* Check solution from generated exact solution.
553*
554 IF( nofact .OR. ( prefac .AND. lsame( equed,
555 $ 'N' ) ) ) THEN
556 CALL dget04( n, nrhs, x, lda, xact, lda,
557 $ rcondc, result( 3 ) )
558 ELSE
559 CALL dget04( n, nrhs, x, lda, xact, lda,
560 $ roldc, result( 3 ) )
561 END IF
562*
563* Check the error bounds from iterative
564* refinement.
565*
566 CALL dpot05( uplo, n, nrhs, asav, lda, b, lda,
567 $ x, lda, xact, lda, rwork,
568 $ rwork( nrhs+1 ), result( 4 ) )
569 ELSE
570 k1 = 6
571 END IF
572*
573* Compare RCOND from DPOSVX with the computed value
574* in RCONDC.
575*
576 result( 6 ) = dget06( rcond, rcondc )
577*
578* Print information about the tests that did not pass
579* the threshold.
580*
581 DO 80 k = k1, 6
582 IF( result( k ).GE.thresh ) THEN
583 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
584 $ CALL aladhd( nout, path )
585 IF( prefac ) THEN
586 WRITE( nout, fmt = 9997 )'DPOSVX', fact,
587 $ uplo, n, equed, imat, k, result( k )
588 ELSE
589 WRITE( nout, fmt = 9998 )'DPOSVX', fact,
590 $ uplo, n, imat, k, result( k )
591 END IF
592 nfail = nfail + 1
593 END IF
594 80 CONTINUE
595 nrun = nrun + 7 - k1
596 90 CONTINUE
597 100 CONTINUE
598 110 CONTINUE
599 120 CONTINUE
600 130 CONTINUE
601*
602* Print a summary of the results.
603*
604 CALL alasvm( path, nout, nfail, nrun, nerrs )
605*
606 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', N =', i5, ', type ', i1,
607 $ ', test(', i1, ')=', g12.5 )
608 9998 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
609 $ ', type ', i1, ', test(', i1, ')=', g12.5 )
610 9997 FORMAT( 1x, a, ', FACT=''', a1, ''', UPLO=''', a1, ''', N=', i5,
611 $ ', EQUED=''', a1, ''', type ', i1, ', test(', i1, ') =',
612 $ g12.5 )
613 RETURN
614*
615* End of DDRVPO
616*
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
dlarhs
subroutine dlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
DLARHS
Definition dlarhs.f:205
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
aladhd
subroutine aladhd(iounit, path)
ALADHD
Definition aladhd.f:90
alaerh
subroutine alaerh(path, subnam, info, infoe, opts, m, n, kl, ku, n5, imat, nfail, nerrs, nout)
ALAERH
Definition alaerh.f:147
derrvx
subroutine derrvx(path, nunit)
DERRVX
Definition derrvx.f:55
dget04
subroutine dget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
DGET04
Definition dget04.f:102
dget06
double precision function dget06(rcond, rcondc)
DGET06
Definition dget06.f:55
dlatb4
subroutine dlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
DLATB4
Definition dlatb4.f:120
dlatms
subroutine dlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
DLATMS
Definition dlatms.f:321
dpot01
subroutine dpot01(uplo, n, a, lda, afac, ldafac, rwork, resid)
DPOT01
Definition dpot01.f:104
dpot02
subroutine dpot02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
DPOT02
Definition dpot02.f:127
dpot05
subroutine dpot05(uplo, n, nrhs, a, lda, b, ldb, x, ldx, xact, ldxact, ferr, berr, reslts)
DPOT05
Definition dpot05.f:164
dlacpy
subroutine dlacpy(uplo, m, n, a, lda, b, ldb)
DLACPY copies all or part of one two-dimensional array to another.
Definition dlacpy.f:103
dlansy
double precision function dlansy(norm, uplo, n, a, lda, work)
DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm,...
Definition dlansy.f:122
dlaqsy
subroutine dlaqsy(uplo, n, a, lda, s, scond, amax, equed)
DLAQSY scales a symmetric/Hermitian matrix, using scaling factors computed by spoequ.
Definition dlaqsy.f:133
dlaset
subroutine dlaset(uplo, m, n, alpha, beta, a, lda)
DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
Definition dlaset.f:110
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:48
dpoequ
subroutine dpoequ(n, a, lda, s, scond, amax, info)
DPOEQU
Definition dpoequ.f:112
dposv
subroutine dposv(uplo, n, nrhs, a, lda, b, ldb, info)
DPOSV computes the solution to system of linear equations A * X = B for PO matrices
Definition dposv.f:130
dposvx
subroutine dposvx(fact, uplo, n, nrhs, a, lda, af, ldaf, equed, s, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
DPOSVX computes the solution to system of linear equations A * X = B for PO matrices
Definition dposvx.f:307
dpotrf
subroutine dpotrf(uplo, n, a, lda, info)
DPOTRF
Definition dpotrf.f:107
dpotri
subroutine dpotri(uplo, n, a, lda, info)
DPOTRI
Definition dpotri.f:95
Here is the call graph for this function:
Here is the caller graph for this function: