OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
zdrvsy_aa_2stage.f
Go to the documentation of this file.
1*> \brief \b ZDRVSY_AA_2STAGE
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 ZDRVSY_AA_2STAGE(
12* DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, NMAX,
13* A, AFAC, AINV, B, X, XACT, WORK, RWORK, IWORK,
14* NOUT )
15*
16* .. Scalar Arguments ..
17* LOGICAL TSTERR
18* INTEGER NMAX, NN, NOUT, NRHS
19* DOUBLE PRECISION THRESH
20* ..
21* .. Array Arguments ..
22* LOGICAL DOTYPE( * )
23* INTEGER IWORK( * ), NVAL( * )
24* DOUBLE PRECISION RWORK( * )
25* COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
26* $ WORK( * ), X( * ), XACT( * )
27* ..
28*
29*
30*> \par Purpose:
31* =============
32*>
33*> \verbatim
34*>
35*> ZDRVSY_AA_2STAGE tests the driver routine ZSYSV_AA_2STAGE.
36*> \endverbatim
37*
38* Arguments:
39* ==========
40*
41*> \param[in] DOTYPE
42*> \verbatim
43*> DOTYPE is LOGICAL array, dimension (NTYPES)
44*> The matrix types to be used for testing. Matrices of type j
45*> (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
46*> .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
47*> \endverbatim
48*>
49*> \param[in] NN
50*> \verbatim
51*> NN is INTEGER
52*> The number of values of N contained in the vector NVAL.
53*> \endverbatim
54*>
55*> \param[in] NVAL
56*> \verbatim
57*> NVAL is INTEGER array, dimension (NN)
58*> The values of the matrix dimension N.
59*> \endverbatim
60*>
61*> \param[in] NRHS
62*> \verbatim
63*> NRHS is INTEGER
64*> The number of right hand side vectors to be generated for
65*> each linear system.
66*> \endverbatim
67*>
68*> \param[in] THRESH
69*> \verbatim
70*> THRESH is DOUBLE PRECISION
71*> The threshold value for the test ratios. A result is
72*> included in the output file if RESULT >= THRESH. To have
73*> every test ratio printed, use THRESH = 0.
74*> \endverbatim
75*>
76*> \param[in] TSTERR
77*> \verbatim
78*> TSTERR is LOGICAL
79*> Flag that indicates whether error exits are to be tested.
80*> \endverbatim
81*>
82*> \param[in] NMAX
83*> \verbatim
84*> NMAX is INTEGER
85*> The maximum value permitted for N, used in dimensioning the
86*> work arrays.
87*> \endverbatim
88*>
89*> \param[out] A
90*> \verbatim
91*> A is COMPLEX*16 array, dimension (NMAX*NMAX)
92*> \endverbatim
93*>
94*> \param[out] AFAC
95*> \verbatim
96*> AFAC is COMPLEX*16 array, dimension (NMAX*NMAX)
97*> \endverbatim
98*>
99*> \param[out] AINV
100*> \verbatim
101*> AINV is COMPLEX*16 array, dimension (NMAX*NMAX)
102*> \endverbatim
103*>
104*> \param[out] B
105*> \verbatim
106*> B is COMPLEX*16 array, dimension (NMAX*NRHS)
107*> \endverbatim
108*>
109*> \param[out] X
110*> \verbatim
111*> X is COMPLEX*16 array, dimension (NMAX*NRHS)
112*> \endverbatim
113*>
114*> \param[out] XACT
115*> \verbatim
116*> XACT is COMPLEX*16 array, dimension (NMAX*NRHS)
117*> \endverbatim
118*>
119*> \param[out] WORK
120*> \verbatim
121*> WORK is COMPLEX*16 array, dimension (NMAX*max(2,NRHS))
122*> \endverbatim
123*>
124*> \param[out] RWORK
125*> \verbatim
126*> RWORK is COMPLEX*16 array, dimension (NMAX+2*NRHS)
127*> \endverbatim
128*>
129*> \param[out] IWORK
130*> \verbatim
131*> IWORK is INTEGER 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 zdrvsy_aa_2stage(
152 $ DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
153 $ NMAX, A, AFAC, AINV, B, X, XACT, WORK,
154 $ RWORK, IWORK, NOUT )
155*
156* -- LAPACK test routine --
157* -- LAPACK is a software package provided by Univ. of Tennessee, --
158* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159*
160* .. Scalar Arguments ..
161 LOGICAL TSTERR
162 INTEGER NMAX, NN, NOUT, NRHS
163 DOUBLE PRECISION THRESH
164* ..
165* .. Array Arguments ..
166 LOGICAL DOTYPE( * )
167 INTEGER IWORK( * ), NVAL( * )
168 DOUBLE PRECISION RWORK( * )
169 COMPLEX*16 A( * ), AFAC( * ), AINV( * ), B( * ),
170 $ work( * ), x( * ), xact( * )
171* ..
172*
173* =====================================================================
174*
175* .. Parameters ..
176 DOUBLE PRECISION ZERO
177 PARAMETER ( ZERO = 0.0d+0 )
178 COMPLEX*16 CZERO
179 parameter( czero = ( 0.0d+0, 0.0d+0 ) )
180 INTEGER NTYPES, NTESTS
181 parameter( ntypes = 10, ntests = 3 )
182 INTEGER NFACT
183 parameter( nfact = 2 )
184* ..
185* .. Local Scalars ..
186 LOGICAL ZEROT
187 CHARACTER DIST, FACT, TYPE, UPLO, XTYPE
188 CHARACTER*3 MATPATH, PATH
189 INTEGER I, I1, I2, IFACT, IMAT, IN, INFO, IOFF, IUPLO,
190 $ izero, j, k, kl, ku, lda, lwork, mode, n,
191 $ nb, nbmin, nerrs, nfail, nimat, nrun, nt
192 DOUBLE PRECISION ANORM, CNDNUM
193* ..
194* .. Local Arrays ..
195 CHARACTER FACTS( NFACT ), UPLOS( 2 )
196 INTEGER ISEED( 4 ), ISEEDY( 4 )
197 DOUBLE PRECISION RESULT( NTESTS )
198* ..
199* .. External Functions ..
200 DOUBLE PRECISION DGET06, ZLANSY
201 EXTERNAL DGET06, ZLANSY
202* ..
203* .. External Subroutines ..
204 EXTERNAL aladhd, alaerh, alasvm, xlaenv, zerrvx,
205 $ zget04, zlacpy, zlarhs, zlatb4, zlatms,
206 $ zsysv_aa_2stage, zsyt01_aa, zsyt02,
207 $ zsytrf_aa_2stage
208* ..
209* .. Scalars in Common ..
210 LOGICAL LERR, OK
211 CHARACTER*32 SRNAMT
212 INTEGER INFOT, NUNIT
213* ..
214* .. Common blocks ..
215 COMMON / infoc / infot, nunit, ok, lerr
216 COMMON / srnamc / srnamt
217* ..
218* .. Intrinsic Functions ..
219 INTRINSIC cmplx, max, min
220* ..
221* .. Data statements ..
222 DATA iseedy / 1988, 1989, 1990, 1991 /
223 DATA uplos / 'U', 'L' / , facts / 'F', 'N' /
224* ..
225* .. Executable Statements ..
226*
227* Initialize constants and the random number seed.
228*
229* Test path
230*
231 path( 1: 1 ) = 'Zomplex precision'
232 path( 2: 3 ) = 'H2'
233*
234* Path to generate matrices
235*
236 matpath( 1: 1 ) = 'Zomplex precision'
237 matpath( 2: 3 ) = 'SY'
238*
239 nrun = 0
240 nfail = 0
241 nerrs = 0
242 DO 10 i = 1, 4
243 iseed( i ) = iseedy( i )
244 10 CONTINUE
245*
246* Test the error exits
247*
248 IF( tsterr )
249 $ CALL zerrvx( path, nout )
250 infot = 0
251*
252* Set the block size and minimum block size for testing.
253*
254 nb = 1
255 nbmin = 2
256 CALL xlaenv( 1, nb )
257 CALL xlaenv( 2, nbmin )
258*
259* Do for each value of N in NVAL
260*
261 DO 180 in = 1, nn
262 n = nval( in )
263 lda = max( n, 1 )
264 xtype = 'N'
265 nimat = ntypes
266 IF( n.LE.0 )
267 $ nimat = 1
268*
269 DO 170 imat = 1, nimat
270*
271* Do the tests only if DOTYPE( IMAT ) is true.
272*
273 IF( .NOT.dotype( imat ) )
274 $ GO TO 170
275*
276* Skip types 3, 4, 5, or 6 if the matrix size is too small.
277*
278 zerot = imat.GE.3 .AND. imat.LE.6
279 IF( zerot .AND. n.LT.imat-2 )
280 $ GO TO 170
281*
282* Do first for UPLO = 'U', then for UPLO = 'L'
283*
284 DO 160 iuplo = 1, 2
285 uplo = uplos( iuplo )
286*
287* Begin generate the test matrix A.
288*
289* Set up parameters with ZLATB4 for the matrix generator
290* based on the type of matrix to be generated.
291*
292 CALL zlatb4( matpath, imat, n, n, TYPE, kl, ku, anorm,
293 $ mode, cndnum, dist )
294*
295* Generate a matrix with ZLATMS.
296*
297 srnamt = 'ZLATMS'
298 CALL zlatms( n, n, dist, iseed, TYPE, rwork, mode,
299 $ cndnum, anorm, kl, ku, uplo, a, lda,
300 $ work, info )
301*
302* Check error code from ZLATMS and handle error.
303*
304 IF( info.NE.0 ) THEN
305 CALL alaerh( path, 'ZLATMS', info, 0, uplo, n, n,
306 $ -1, -1, -1, imat, nfail, nerrs, nout )
307 GO TO 160
308 END IF
309*
310* For types 3-6, zero one or more rows and columns of
311* the matrix to test that INFO is returned correctly.
312*
313 IF( zerot ) THEN
314 IF( imat.EQ.3 ) THEN
315 izero = 1
316 ELSE IF( imat.EQ.4 ) THEN
317 izero = n
318 ELSE
319 izero = n / 2 + 1
320 END IF
321*
322 IF( imat.LT.6 ) THEN
323*
324* Set row and column IZERO to zero.
325*
326 IF( iuplo.EQ.1 ) THEN
327 ioff = ( izero-1 )*lda
328 DO 20 i = 1, izero - 1
329 a( ioff+i ) = czero
330 20 CONTINUE
331 ioff = ioff + izero
332 DO 30 i = izero, n
333 a( ioff ) = czero
334 ioff = ioff + lda
335 30 CONTINUE
336 ELSE
337 ioff = izero
338 DO 40 i = 1, izero - 1
339 a( ioff ) = czero
340 ioff = ioff + lda
341 40 CONTINUE
342 ioff = ioff - izero
343 DO 50 i = izero, n
344 a( ioff+i ) = czero
345 50 CONTINUE
346 END IF
347 ELSE
348 ioff = 0
349 IF( iuplo.EQ.1 ) THEN
350*
351* Set the first IZERO rows and columns to zero.
352*
353 DO 70 j = 1, n
354 i2 = min( j, izero )
355 DO 60 i = 1, i2
356 a( ioff+i ) = czero
357 60 CONTINUE
358 ioff = ioff + lda
359 70 CONTINUE
360 izero = 1
361 ELSE
362*
363* Set the first IZERO rows and columns to zero.
364*
365 ioff = 0
366 DO 90 j = 1, n
367 i1 = max( j, izero )
368 DO 80 i = i1, n
369 a( ioff+i ) = czero
370 80 CONTINUE
371 ioff = ioff + lda
372 90 CONTINUE
373 END IF
374 END IF
375 ELSE
376 izero = 0
377 END IF
378*
379* End generate the test matrix A.
380*
381*
382 DO 150 ifact = 1, nfact
383*
384* Do first for FACT = 'F', then for other values.
385*
386 fact = facts( ifact )
387*
388* Form an exact solution and set the right hand side.
389*
390 srnamt = 'ZLARHS'
391 CALL zlarhs( matpath, xtype, uplo, ' ', n, n, kl, ku,
392 $ nrhs, a, lda, xact, lda, b, lda, iseed,
393 $ info )
394 xtype = 'C'
395*
396* --- Test ZSYSV_AA_2STAGE ---
397*
398 IF( ifact.EQ.2 ) THEN
399 CALL zlacpy( uplo, n, n, a, lda, afac, lda )
400 CALL zlacpy( 'Full', n, nrhs, b, lda, x, lda )
401*
402* Factor the matrix and solve the system using ZSYSV_AA.
403*
404 srnamt = 'ZSYSV_AA_2STAGE '
405 lwork = min(n*nb, 3*nmax*nmax)
406 CALL zsysv_aa_2stage( uplo, n, nrhs, afac, lda,
407 $ ainv, (3*nb+1)*n,
408 $ iwork, iwork( 1+n ),
409 $ x, lda, work, lwork, info )
410*
411* Adjust the expected value of INFO to account for
412* pivoting.
413*
414 IF( izero.GT.0 ) THEN
415 j = 1
416 k = izero
417 100 CONTINUE
418 IF( j.EQ.k ) THEN
419 k = iwork( j )
420 ELSE IF( iwork( j ).EQ.k ) THEN
421 k = j
422 END IF
423 IF( j.LT.k ) THEN
424 j = j + 1
425 GO TO 100
426 END IF
427 ELSE
428 k = 0
429 END IF
430*
431* Check error code from ZSYSV_AA_2STAGE .
432*
433 IF( info.NE.k ) THEN
434 CALL alaerh( path, 'ZSYSV_AA_2STAGE', info, k,
435 $ uplo, n, n, -1, -1, nrhs,
436 $ imat, nfail, nerrs, nout )
437 GO TO 120
438 ELSE IF( info.NE.0 ) THEN
439 GO TO 120
440 END IF
441*
442* Compute residual of the computed solution.
443*
444 CALL zlacpy( 'Full', n, nrhs, b, lda, work, lda )
445 CALL zsyt02( uplo, n, nrhs, a, lda, x, lda, work,
446 $ lda, rwork, result( 1 ) )
447*
448* Reconstruct matrix from factors and compute
449* residual.
450*
451c CALL ZSY01_AA( UPLO, N, A, LDA, AFAC, LDA,
452c $ IWORK, AINV, LDA, RWORK,
453c $ RESULT( 2 ) )
454c NT = 2
455 nt = 1
456*
457* Print information about the tests that did not pass
458* the threshold.
459*
460 DO 110 k = 1, nt
461 IF( result( k ).GE.thresh ) THEN
462 IF( nfail.EQ.0 .AND. nerrs.EQ.0 )
463 $ CALL aladhd( nout, path )
464 WRITE( nout, fmt = 9999 )'ZSYSV_AA_2STAGE ',
465 $ uplo, n, imat, k, result( k )
466 nfail = nfail + 1
467 END IF
468 110 CONTINUE
469 nrun = nrun + nt
470 120 CONTINUE
471 END IF
472*
473 150 CONTINUE
474*
475 160 CONTINUE
476 170 CONTINUE
477 180 CONTINUE
478*
479* Print a summary of the results.
480*
481 CALL alasvm( path, nout, nfail, nrun, nerrs )
482*
483 9999 FORMAT( 1x, a, ', UPLO=''', a1, ''', n =', I5, ', type ', I2,
484 $ ', test ', I2, ', ratio =', G12.5 )
485 RETURN
486*
487* End of ZDRVSY_AA_2STAGE
488*
489 END
cmplx
float cmplx[2]
Definition pblas.h:136
xlaenv
subroutine xlaenv(ispec, nvalue)
XLAENV
Definition xlaenv.f:81
alasvm
subroutine alasvm(type, nout, nfail, nrun, nerrs)
ALASVM
Definition alasvm.f:73
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
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
zsysv_aa_2stage
subroutine zsysv_aa_2stage(uplo, n, nrhs, a, lda, tb, ltb, ipiv, ipiv2, b, ldb, work, lwork, info)
ZSYSV_AA_2STAGE computes the solution to system of linear equations A * X = B for SY matrices
Definition zsysv_aa_2stage.f:186
zsytrf_aa_2stage
subroutine zsytrf_aa_2stage(uplo, n, a, lda, tb, ltb, ipiv, ipiv2, work, lwork, info)
ZSYTRF_AA_2STAGE
Definition zsytrf_aa_2stage.f:160
zlarhs
subroutine zlarhs(path, xtype, uplo, trans, m, n, kl, ku, nrhs, a, lda, x, ldx, b, ldb, iseed, info)
ZLARHS
Definition zlarhs.f:208
zerrvx
subroutine zerrvx(path, nunit)
ZERRVX
Definition zerrvx.f:55
zget04
subroutine zget04(n, nrhs, x, ldx, xact, ldxact, rcond, resid)
ZGET04
Definition zget04.f:102
zdrvsy_aa_2stage
subroutine zdrvsy_aa_2stage(dotype, nn, nval, nrhs, thresh, tsterr, nmax, a, afac, ainv, b, x, xact, work, rwork, iwork, nout)
ZDRVSY_AA_2STAGE
Definition zdrvsy_aa_2stage.f:155
zsyt01_aa
subroutine zsyt01_aa(uplo, n, a, lda, afac, ldafac, ipiv, c, ldc, rwork, resid)
ZSYT01
Definition zsyt01_aa.f:124
zsyt02
subroutine zsyt02(uplo, n, nrhs, a, lda, x, ldx, b, ldb, rwork, resid)
ZSYT02
Definition zsyt02.f:127
zlatb4
subroutine zlatb4(path, imat, m, n, type, kl, ku, anorm, mode, cndnum, dist)
ZLATB4
Definition zlatb4.f:121
zlatms
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
ZLATMS
Definition zlatms.f:332
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21