SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

◆ pdseprtst()

subroutine pdseprtst ( integer, dimension( * )  desca,
character  uplo,
integer  n,
integer  mattype,
character  subtests,
double precision  thresh,
integer  order,
double precision  abstol,
integer, dimension( 4 )  iseed,
double precision, dimension( lda, * )  a,
double precision, dimension( lda, * )  copya,
double precision, dimension( lda, * )  z,
integer  lda,
double precision, dimension( * )  win,
double precision, dimension( * )  wnew,
integer, dimension( * )  ifail,
integer, dimension( * )  iclustr,
double precision, dimension( * )  gap,
integer  iprepad,
integer  ipostpad,
double precision, dimension( * )  work,
integer  lwork,
integer, dimension( * )  iwork,
integer  liwork,
character  hetero,
integer  nout,
integer  info 
)

Definition at line 1 of file pdseprtst.f.

6*
7* -- ScaLAPACK routine (@(MODE)version *TBA*) --
8* University of California, Berkeley and
9* University of Tennessee, Knoxville.
10* October 21, 2006
11*
12 IMPLICIT NONE
13*
14* .. Scalar Arguments ..
15 CHARACTER HETERO, SUBTESTS, UPLO
16 INTEGER INFO, IPOSTPAD, IPREPAD, LDA, LIWORK, LWORK,
17 $ MATTYPE, N, NOUT, ORDER
18 DOUBLE PRECISION ABSTOL, THRESH
19* ..
20* .. Array Arguments ..
21 INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
22 $ ISEED( 4 ), IWORK( * )
23 DOUBLE PRECISION A( LDA, * ), COPYA( LDA, * ), GAP( * ),
24 $ WIN( * ), WNEW( * ), WORK( * ), Z( LDA, * )
25* ..
26*
27* Purpose
28* =======
29*
30* PDSEPRTST builds a random matrix and runs PDSYEVR to
31* compute the eigenvalues and eigenvectors. Then it performs two tests
32* to determine if the result is good enough. The two tests are:
33* |AQ -QL| / (abstol + ulp * norm(A) )
34* and
35* |QT * Q - I| / ulp * norm(A)
36*
37* The random matrix built depends upon the following parameters:
38* N, NB, ISEED, ORDER
39*
40* Arguments
41* =========
42*
43* NP = the number of rows local to a given process.
44* NQ = the number of columns local to a given process.
45*
46* DESCA (global and local input) INTEGER array of dimension DLEN_
47* The array descriptor for the distributed matrices
48*
49* UPLO (global input) CHARACTER*1
50* Specifies whether the upper or lower triangular part of the
51* matrix A is stored:
52* = 'U': Upper triangular
53* = 'L': Lower triangular
54*
55* N (global input) INTEGER
56* Size of the matrix to be tested. (global size)
57*
58* MATTYPE (global input) INTEGER
59* Matrix type
60* Currently, the list of possible types is:
61*
62* (1) The zero matrix.
63* (2) The identity matrix.
64*
65* (3) A diagonal matrix with evenly spaced entries
66* 1, ..., ULP and random signs.
67* (ULP = (first number larger than 1) - 1 )
68* (4) A diagonal matrix with geometrically spaced entries
69* 1, ..., ULP and random signs.
70* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
71* and random signs.
72*
73* (6) Same as (4), but multiplied by SQRT( overflow threshold )
74* (7) Same as (4), but multiplied by SQRT( underflow threshold )
75*
76* (8) A matrix of the form U' D U, where U is orthogonal and
77* D has evenly spaced entries 1, ..., ULP with random signs
78* on the diagonal.
79*
80* (9) A matrix of the form U' D U, where U is orthogonal and
81* D has geometrically spaced entries 1, ..., ULP with random
82* signs on the diagonal.
83*
84* (10) A matrix of the form U' D U, where U is orthogonal and
85* D has "clustered" entries 1, ULP,..., ULP with random
86* signs on the diagonal.
87*
88* (11) Same as (8), but multiplied by SQRT( overflow threshold )
89* (12) Same as (8), but multiplied by SQRT( underflow threshold )
90*
91* (13) A matrix with random entries chosen from (-1,1).
92* (14) Same as (13), but multiplied by SQRT( overflow threshold )
93* (15) Same as (13), but multiplied by SQRT( underflow threshold )
94* (16) Same as (8), but diagonal elements are all positive.
95* (17) Same as (9), but diagonal elements are all positive.
96* (18) Same as (10), but diagonal elements are all positive.
97* (19) Same as (16), but multiplied by SQRT( overflow threshold )
98* (20) Same as (16), but multiplied by SQRT( underflow threshold )
99* (21) A tridiagonal matrix that is a direct sum of smaller diagonally
100* dominant submatrices. Each unreduced submatrix has geometrically
101* spaced diagonal entries 1, ..., ULP.
102* (22) A matrix of the form U' D U, where U is orthogonal and
103* D has ceil(lgN) "clusters" at 0,1,2,...,ceil(lgN)-1. The
104* size of the cluster at the value I is 2^I.
105*
106* SUBTESTS (global input) CHARACTER*1
107* 'Y' - Perform subset tests
108* 'N' - Do not perform subset tests
109*
110* THRESH (global input) DOUBLE PRECISION
111* A test will count as "failed" if the "error", computed as
112* described below, exceeds THRESH. Note that the error
113* is scaled to be O(1), so THRESH should be a reasonably
114* small multiple of 1, e.g., 10 or 100. In particular,
115* it should not depend on the precision (single vs. double)
116* or the size of the matrix. It must be at least zero.
117*
118* ORDER (global input) INTEGER
119* Number of reflectors used in test matrix creation.
120* If ORDER is large, it will
121* take more time to create the test matrices but they will
122* be closer to random.
123* ORDER .lt. N not implemented
124*
125* ABSTOL (global input) DOUBLE PRECISION
126* For the purposes of this test, ABSTOL=0.0 is fine.
127* THis test does not test for high relative accuracy.
128*
129* ISEED (global input/output) INTEGER array, dimension (4)
130* On entry, the seed of the random number generator; the array
131* elements must be between 0 and 4095, and ISEED(4) must be
132* odd.
133* On exit, the seed is updated.
134*
135* A (local workspace) DOUBLE PRECISION array, dim (N*N)
136* global dimension (N, N), local dimension (LDA, NQ)
137* The test matrix, which is then overwritten.
138* A is distributed in a block cyclic manner over both rows
139* and columns. The actual location of a particular element
140* in A is controlled by the values of NPROW, NPCOL, and NB.
141*
142* COPYA (local workspace) DOUBLE PRECISION array, dim (N, N)
143* COPYA is used to hold an identical copy of the array A
144* identical in both form and content to A
145*
146* Z (local workspace) DOUBLE PRECISION array, dim (N*N)
147* Z is distributed in the same manner as A
148* Z is used as workspace by the test routines
149* PDSEPCHK and PDSEPQTQ
150*
151* W (local workspace) DOUBLE PRECISION array, dimension (N)
152* On normal exit, the first M entries
153* contain the selected eigenvalues in ascending order.
154*
155* IFAIL (global workspace) INTEGER array, dimension (N)
156* Not used, only for backward compatibility
157*
158* WORK (local workspace) DOUBLE PRECISION array, dimension (LWORK)
159*
160* LWORK (local input) INTEGER
161* The length of the array WORK. LWORK >= SIZETST as
162* returned by PDLASIZESEPR
163*
164* IWORK (local workspace) INTEGER array, dimension (LIWORK)
165*
166* LIWORK (local input) INTEGER
167* The length of the array IWORK. LIWORK >= ISIZETST as
168* returned by PDLASIZESEPR
169*
170* HETERO (input) INTEGER
171*
172* NOUT (local input) INTEGER
173* The unit number for output file. Only used on node 0.
174* NOUT = 6, output to screen,
175* NOUT = 0, output to stderr.
176* NOUT = 13, output to file, divide thresh by 10.0
177* NOUT = 14, output to file, divide thresh by 20.0
178* (This hack allows us to test more stringently internally
179* so that when errors on found on other computers they will
180* be serious enough to warrant our attention.)
181*
182* INFO (global output) INTEGER
183* -3 This process is not involved
184* 0 Test succeeded (passed |AQ -QL| and |QT*Q - I| tests)
185* 1 At least one test failed
186* 2 Residual test were not performed, thresh <= 0.0
187* 3 Test was skipped because of inadequate memory space
188*
189* .. Parameters ..
190 INTEGER CTXT_, MB_, NB_, RSRC_, CSRC_, LLD_
191 parameter( ctxt_ = 2, mb_ = 5, nb_ = 6,
192 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
193 DOUBLE PRECISION HALF, ONE, TEN, ZERO
194 parameter( zero = 0.0d0, one = 1.0d0,
195 $ ten = 10.0d0, half = 0.5d0 )
196 DOUBLE PRECISION PADVAL
197 parameter( padval = 19.25d0 )
198 INTEGER MAXTYP
199 parameter( maxtyp = 22 )
200* ..
201*
202* .. Local Scalars ..
203 LOGICAL WKNOWN
204 CHARACTER JOBZ, RANGE
205 CHARACTER*14 PASSED
206 INTEGER CONTEXT, I, IAM, IHETERO, IINFO, IL, IMODE, IN,
207 $ INDD, INDWORK, ISIZESUBTST, ISIZEEVR,
208 $ ISIZETST, ITYPE, IU, J, LLWORK, LEVRSIZE,
209 $ MAXSIZE, MYCOL, MYROW, NB, NGEN, NLOC,
210 $ NNODES, NP, NPCOL, NPROW, NQ, RES, SIZECHK,
211 $ SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF, SIZEQTQ,
212 $ SIZESUBTST, SIZEEVR, SIZETMS,
213 $ SIZETST, VALSIZE, VECSIZE
214 DOUBLE PRECISION ANINV, ANORM, COND, MAXQTQNRM, MAXTSTNRM, OVFL,
215 $ QTQNRM, RTOVFL, RTUNFL, TEMP1, TSTNRM, ULP,
216 $ ULPINV, UNFL, VL, VU
217* ..
218* .. Local Arrays ..
219 INTEGER ISEEDIN( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
220 $ KTYPE( MAXTYP )
221 DOUBLE PRECISION CTIME( 10 ), WTIME( 10 )
222* ..
223* .. External Functions ..
224 LOGICAL LSAME
225 INTEGER NUMROC
226 DOUBLE PRECISION DLARAN, PDLAMCH
227 EXTERNAL dlaran, lsame, numroc, pdlamch
228* ..
229* .. External Subroutines ..
230 EXTERNAL blacs_gridinfo, blacs_pinfo, dlabad, dlasrt,
231 $ dlatms, igamx2d, igebr2d, igebs2d, pdchekpad,
232 $ pdelset, pdfillpad, pdlaset, pdlasizesepr,
233 $ pdlasizesyevr, pdlatms, pdmatgen, pdseprsubtst,
234 $ slcombine
235* ..
236* .. Intrinsic Functions ..
237 INTRINSIC abs, dble, int, max, min, sqrt
238* ..
239* .. Data statements ..
240 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
241 $ 8, 8, 9, 9, 9, 9, 9, 10, 11 /
242 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
243 $ 2, 3, 1, 1, 1, 2, 3, 1, 1 /
244 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
245 $ 0, 0, 4, 3, 1, 4, 4, 3, 0 /
246* ..
247* .. Executable Statements ..
248*
249 info = 0
250 passed = 'PASSED EVR'
251 context = desca( ctxt_ )
252 nb = desca( nb_ )
253*
254 CALL blacs_pinfo( iam, nnodes )
255 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
256*
257* Distribute HETERO across processes
258*
259 IF( iam.EQ.0 ) THEN
260 IF( lsame( hetero, 'Y' ) ) THEN
261 ihetero = 2
262 ELSE
263 ihetero = 1
264 END IF
265 CALL igebs2d( context, 'All', ' ', 1, 1, ihetero, 1 )
266 ELSE
267 CALL igebr2d( context, 'All', ' ', 1, 1, ihetero, 1, 0, 0 )
268 END IF
269 IF( ihetero.EQ.2 ) THEN
270 hetero = 'Y'
271 ELSE
272 hetero = 'N'
273 END IF
274*
275* Make sure that there is enough memory
276*
277 CALL pdlasizesepr( desca, iprepad, ipostpad, sizemqrleft,
278 $ sizemqrright, sizeqrf, sizetms, sizeqtq,
279 $ sizechk, sizeevr, isizeevr,
280 $ sizesubtst,
281 $ isizesubtst, sizetst, isizetst )
282 IF( lwork.LT.sizetst ) THEN
283 info = 3
284 END IF
285*
286 CALL igamx2d( context, 'a', ' ', 1, 1, info, 1, 1, 1, -1, -1, 0 )
287*
288 IF( info.EQ.0 ) THEN
289*
290 indd = 1
291 indwork = indd + n
292 llwork = lwork - indwork + 1
293*
294 ulp = pdlamch( context, 'P' )
295 ulpinv = one / ulp
296 unfl = pdlamch( context, 'Safe min' )
297 ovfl = one / unfl
298 CALL dlabad( unfl, ovfl )
299 rtunfl = sqrt( unfl )
300 rtovfl = sqrt( ovfl )
301 aninv = one / dble( max( 1, n ) )
302*
303* This ensures that everyone starts out with the same seed.
304*
305 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
306 CALL igebs2d( context, 'a', ' ', 4, 1, iseed, 4 )
307 ELSE
308 CALL igebr2d( context, 'a', ' ', 4, 1, iseed, 4, 0, 0 )
309 END IF
310 iseedin( 1 ) = iseed( 1 )
311 iseedin( 2 ) = iseed( 2 )
312 iseedin( 3 ) = iseed( 3 )
313 iseedin( 4 ) = iseed( 4 )
314*
315* Compute the matrix A
316*
317* Control parameters:
318*
319* KMAGN KMODE KTYPE
320* =1 O(1) clustered 1 zero
321* =2 large clustered 2 identity
322* =3 small exponential (none)
323* =4 arithmetic diagonal, (w/ eigenvalues)
324* =5 random log symmetric, w/ eigenvalues
325* =6 random (none)
326* =7 random diagonal
327* =8 random symmetric
328* =9 positive definite
329* =10 block diagonal with tridiagonal blocks
330* =11 Geometrically sized clusters.
331*
332 itype = ktype( mattype )
333 imode = kmode( mattype )
334*
335* Compute norm
336*
337 GO TO ( 10, 20, 30 )kmagn( mattype )
338*
339 10 CONTINUE
340 anorm = one
341 GO TO 40
342*
343 20 CONTINUE
344 anorm = ( rtovfl*ulp )*aninv
345 GO TO 40
346*
347 30 CONTINUE
348 anorm = rtunfl*n*ulpinv
349 GO TO 40
350*
351 40 CONTINUE
352 IF( mattype.LE.15 ) THEN
353 cond = ulpinv
354 ELSE
355 cond = ulpinv*aninv / ten
356 END IF
357*
358* Special Matrices
359*
360 IF( itype.EQ.1 ) THEN
361*
362* Zero Matrix
363*
364 DO 50 i = 1, n
365 work( indd+i-1 ) = zero
366 50 CONTINUE
367 CALL pdlaset( 'All', n, n, zero, zero, copya, 1, 1, desca )
368 wknown = .true.
369*
370 ELSE IF( itype.EQ.2 ) THEN
371*
372* Identity Matrix
373*
374 DO 60 i = 1, n
375 work( indd+i-1 ) = one
376 60 CONTINUE
377 CALL pdlaset( 'All', n, n, zero, one, copya, 1, 1, desca )
378 wknown = .true.
379*
380 ELSE IF( itype.EQ.4 ) THEN
381*
382* Diagonal Matrix, [Eigen]values Specified
383*
384 CALL pdfillpad( desca( ctxt_ ), sizetms, 1, work( indwork ),
385 $ sizetms, iprepad, ipostpad, padval+1.0d0 )
386*
387 CALL pdlatms( n, n, 'S', iseed, 'S', work( indd ), imode,
388 $ cond, anorm, 0, 0, 'N', copya, 1, 1, desca,
389 $ order, work( indwork+iprepad ), sizetms,
390 $ iinfo )
391 wknown = .true.
392*
393 CALL pdchekpad( desca( ctxt_ ), 'PDLATMS1-WORK', sizetms, 1,
394 $ work( indwork ), sizetms, iprepad, ipostpad,
395 $ padval+1.0d0 )
396*
397 ELSE IF( itype.EQ.5 ) THEN
398*
399* symmetric, eigenvalues specified
400*
401 CALL pdfillpad( desca( ctxt_ ), sizetms, 1, work( indwork ),
402 $ sizetms, iprepad, ipostpad, padval+2.0d0 )
403*
404 CALL pdlatms( n, n, 'S', iseed, 'S', work( indd ), imode,
405 $ cond, anorm, n, n, 'N', copya, 1, 1, desca,
406 $ order, work( indwork+iprepad ), sizetms,
407 $ iinfo )
408*
409 CALL pdchekpad( desca( ctxt_ ), 'PDLATMS2-WORK', sizetms, 1,
410 $ work( indwork ), sizetms, iprepad, ipostpad,
411 $ padval+2.0d0 )
412*
413 wknown = .true.
414*
415 ELSE IF( itype.EQ.8 ) THEN
416*
417* symmetric, random eigenvalues
418*
419 np = numroc( n, desca( mb_ ), myrow, 0, nprow )
420 nq = numroc( n, desca( nb_ ), mycol, 0, npcol )
421 CALL pdmatgen( desca( ctxt_ ), 'S', 'N', n, n, desca( mb_ ),
422 $ desca( nb_ ), copya, desca( lld_ ),
423 $ desca( rsrc_ ), desca( csrc_ ), iseed( 1 ),
424 $ 0, np, 0, nq, myrow, mycol, nprow, npcol )
425 info = 0
426 wknown = .false.
427*
428 ELSE IF( itype.EQ.9 ) THEN
429*
430* Positive definite, eigenvalues specified.
431*
432 CALL pdfillpad( desca( ctxt_ ), sizetms, 1, work( indwork ),
433 $ sizetms, iprepad, ipostpad, padval+3.0d0 )
434*
435 CALL pdlatms( n, n, 'S', iseed, 'S', work( indd ), imode,
436 $ cond, anorm, n, n, 'N', copya, 1, 1, desca,
437 $ order, work( indwork+iprepad ), sizetms,
438 $ iinfo )
439*
440 wknown = .true.
441*
442 CALL pdchekpad( desca( ctxt_ ), 'PDLATMS3-WORK', sizetms, 1,
443 $ work( indwork ), sizetms, iprepad, ipostpad,
444 $ padval+3.0d0 )
445*
446 ELSE IF( itype.EQ.10 ) THEN
447*
448* Block diagonal matrix with each block being a positive
449* definite tridiagonal submatrix.
450*
451 CALL pdlaset( 'All', n, n, zero, zero, copya, 1, 1, desca )
452 np = numroc( n, desca( mb_ ), 0, 0, nprow )
453 nq = numroc( n, desca( nb_ ), 0, 0, npcol )
454 nloc = min( np, nq )
455 ngen = 0
456 70 CONTINUE
457*
458 IF( ngen.LT.n ) THEN
459 in = min( 1+int( dlaran( iseed )*dble( nloc ) ), n-ngen )
460*
461 CALL dlatms( in, in, 'S', iseed, 'P', work( indd ),
462 $ imode, cond, anorm, 1, 1, 'N', a, lda,
463 $ work( indwork ), iinfo )
464*
465 DO 80 i = 2, in
466 temp1 = abs( a( i-1, i ) ) /
467 $ sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
468 IF( temp1.GT.half ) THEN
469 a( i-1, i ) = half*sqrt( abs( a( i-1, i-1 )*a( i,
470 $ i ) ) )
471 a( i, i-1 ) = a( i-1, i )
472 END IF
473 80 CONTINUE
474 CALL pdelset( copya, ngen+1, ngen+1, desca, a( 1, 1 ) )
475 DO 90 i = 2, in
476 CALL pdelset( copya, ngen+i, ngen+i, desca,
477 $ a( i, i ) )
478 CALL pdelset( copya, ngen+i-1, ngen+i, desca,
479 $ a( i-1, i ) )
480 CALL pdelset( copya, ngen+i, ngen+i-1, desca,
481 $ a( i, i-1 ) )
482 90 CONTINUE
483 ngen = ngen + in
484 GO TO 70
485 END IF
486 wknown = .false.
487*
488 ELSE IF( itype.EQ.11 ) THEN
489*
490* Geometrically sized clusters. Eigenvalues: 0,1,1,2,2,2,2,...
491*
492 ngen = 0
493 j = 1
494 temp1 = zero
495 100 CONTINUE
496 IF( ngen.LT.n ) THEN
497 in = min( j, n-ngen )
498 DO 110 i = 0, in - 1
499 work( indd+ngen+i ) = temp1
500 110 CONTINUE
501 temp1 = temp1 + one
502 j = 2*j
503 ngen = ngen + in
504 GO TO 100
505 END IF
506*
507 CALL pdfillpad( desca( ctxt_ ), sizetms, 1, work( indwork ),
508 $ sizetms, iprepad, ipostpad, padval+4.0d0 )
509*
510 CALL pdlatms( n, n, 'S', iseed, 'S', work( indd ), imode,
511 $ cond, anorm, 0, 0, 'N', copya, 1, 1, desca,
512 $ order, work( indwork+iprepad ), sizetms,
513 $ iinfo )
514*
515 CALL pdchekpad( desca( ctxt_ ), 'PDLATMS4-WORK', sizetms, 1,
516 $ work( indwork ), sizetms, iprepad, ipostpad,
517 $ padval+4.0d0 )
518*
519 ELSE
520 iinfo = 1
521 END IF
522*
523 IF( wknown )
524 $ CALL dlasrt( 'I', n, work( indd ), iinfo )
525*
526 CALL pdlasizesyevr( wknown, 'A', n, desca, vl, vu, il, iu,
527 $ iseed, work( indd ), maxsize, vecsize,
528 $ valsize )
529 levrsize = min( maxsize, llwork )
530*
531 CALL pdseprsubtst( wknown, 'v', 'a', uplo, n, vl, vu, il, iu,
532 $ thresh, abstol, a, copya, z, 1, 1, desca,
533 $ work( indd ), win, ifail, iclustr, gap,
534 $ iprepad, ipostpad, work( indwork ), llwork,
535 $ levrsize, iwork, isizeevr, res, tstnrm,
536 $ qtqnrm, nout )
537*
538 maxtstnrm = tstnrm
539 maxqtqnrm = qtqnrm
540*
541 IF( thresh.LE.zero ) THEN
542 passed = 'SKIPPED '
543 info = 2
544 ELSE IF( res.NE.0 ) THEN
545 passed = 'FAILED '
546 info = 1
547 END IF
548 END IF
549*
550 IF( thresh.GT.zero .AND. lsame( subtests, 'Y' ) ) THEN
551*
552* Subtest 1: JOBZ = 'N', RANGE = 'A', minimum memory
553*
554 IF( info.EQ.0 ) THEN
555*
556 jobz = 'N'
557 range = 'A'
558 CALL pdlasizesyevr( .true., range, n, desca, vl, vu, il, iu,
559 $ iseed, win( 1+iprepad ), maxsize,
560 $ vecsize, valsize )
561*
562 levrsize = valsize
563*
564 CALL pdseprsubtst( .true., jobz, range, uplo, n, vl, vu, il,
565 $ iu, thresh, abstol, a, copya, z, 1, 1,
566 $ desca, win( 1+iprepad ), wnew, ifail,
567 $ iclustr, gap, iprepad, ipostpad,
568 $ work( indwork ), llwork, levrsize,
569 $ iwork, isizeevr, res, tstnrm, qtqnrm,
570 $ nout )
571*
572 IF( res.NE.0 ) THEN
573 maxtstnrm = max( tstnrm, maxtstnrm )
574 maxqtqnrm = max( qtqnrm, maxqtqnrm )
575 passed = 'FAILED stest 1'
576 info = 1
577 END IF
578 END IF
579*
580* Subtest 2: JOBZ = 'N', RANGE = 'I', minimum memory
581*
582 IF( info.EQ.0 ) THEN
583*
584 il = -1
585 iu = -1
586 jobz = 'N'
587 range = 'I'
588*
589* Use PDLASIZESYEVR to choose IL and IU.
590*
591 CALL pdlasizesyevr( .true., range, n, desca, vl, vu, il, iu,
592 $ iseed, win( 1+iprepad ), maxsize,
593 $ vecsize, valsize )
594*
595 levrsize = valsize
596*
597 CALL pdseprsubtst( .true., jobz, range, uplo, n, vl, vu, il,
598 $ iu, thresh, abstol, a, copya, z, 1, 1,
599 $ desca, win( 1+iprepad ), wnew, ifail,
600 $ iclustr, gap, iprepad, ipostpad,
601 $ work( indwork ), llwork, levrsize,
602 $ iwork, isizeevr, res, tstnrm, qtqnrm,
603 $ nout )
604*
605 IF( res.NE.0 ) THEN
606 maxtstnrm = max( tstnrm, maxtstnrm )
607 maxqtqnrm = max( qtqnrm, maxqtqnrm )
608 passed = 'FAILED stest 2'
609 info = 1
610 END IF
611 END IF
612*
613* Subtest 3: JOBZ = 'V', RANGE = 'I', minimum memory
614*
615 IF( info.EQ.0 ) THEN
616 il = -1
617 iu = -1
618 jobz = 'V'
619 range = 'I'
620*
621* We use PDLASIZESYEVR to choose IL and IU for us.
622*
623 CALL pdlasizesyevr( .true., range, n, desca, vl, vu, il, iu,
624 $ iseed, win( 1+iprepad ), maxsize,
625 $ vecsize, valsize )
626*
627 levrsize = vecsize
628*
629 CALL pdseprsubtst( .true., jobz, range, uplo, n, vl, vu, il,
630 $ iu, thresh, abstol, a, copya, z, 1, 1,
631 $ desca, win( 1+iprepad ), wnew, ifail,
632 $ iclustr, gap, iprepad, ipostpad,
633 $ work( indwork ), llwork, levrsize,
634 $ iwork, isizeevr, res, tstnrm, qtqnrm,
635 $ nout )
636*
637 IF( res.NE.0 ) THEN
638 maxtstnrm = max( tstnrm, maxtstnrm )
639 maxqtqnrm = max( qtqnrm, maxqtqnrm )
640 passed = 'FAILED stest 3'
641 info = 1
642 END IF
643 END IF
644*
645* Subtest 4: JOBZ = 'N', RANGE = 'V', minimum memory
646*
647 IF( info.EQ.0 ) THEN
648 vl = one
649 vu = -one
650 jobz = 'N'
651 range = 'V'
652*
653* We use PDLASIZESYEVR to choose IL and IU for us.
654*
655 CALL pdlasizesyevr( .true., range, n, desca, vl, vu, il, iu,
656 $ iseed, win( 1+iprepad ), maxsize,
657 $ vecsize, valsize )
658*
659 levrsize = valsize
660*
661 CALL pdseprsubtst( .true., jobz, range, uplo, n, vl, vu, il,
662 $ iu, thresh, abstol, a, copya, z, 1, 1,
663 $ desca, win( 1+iprepad ), wnew, ifail,
664 $ iclustr, gap, iprepad, ipostpad,
665 $ work( indwork ), llwork, levrsize,
666 $ iwork, isizeevr, res, tstnrm, qtqnrm,
667 $ nout )
668*
669 IF( res.NE.0 ) THEN
670 maxtstnrm = max( tstnrm, maxtstnrm )
671 maxqtqnrm = max( qtqnrm, maxqtqnrm )
672 passed = 'FAILED stest 4'
673 info = 1
674 END IF
675 END IF
676*
677* Subtest 5: JOBZ = 'V', RANGE = 'V', minimum memory
678*
679 IF( info.EQ.0 ) THEN
680 vl = one
681 vu = -one
682 jobz = 'V'
683 range = 'V'
684*
685* We use PDLASIZESYEVR to choose VL and VU for us.
686*
687 CALL pdlasizesyevr( .true., range, n, desca, vl, vu, il, iu,
688 $ iseed, win( 1+iprepad ), maxsize,
689 $ vecsize, valsize )
690*
691 levrsize = vecsize
692*
693 CALL pdseprsubtst( .true., jobz, range, uplo, n, vl, vu, il,
694 $ iu, thresh, abstol, a, copya, z, 1, 1,
695 $ desca, win( 1+iprepad ), wnew, ifail,
696 $ iclustr, gap, iprepad, ipostpad,
697 $ work( indwork ), llwork, levrsize,
698 $ iwork, isizeevr, res, tstnrm, qtqnrm,
699 $ nout )
700*
701 IF( res.NE.0 ) THEN
702 maxtstnrm = max( tstnrm, maxtstnrm )
703 maxqtqnrm = max( qtqnrm, maxqtqnrm )
704 passed = 'FAILED stest 5'
705 info = 1
706 END IF
707 END IF
708 END IF
709*
710 CALL igamx2d( context, 'All', ' ', 1, 1, info, 1, -1, -1, -1, -1,
711 $ -1 )
712 IF( info.EQ.1 ) THEN
713 IF( iam.EQ.0 .AND. .false. ) THEN
714 WRITE( nout, fmt = 9994 )'C '
715 WRITE( nout, fmt = 9993 )iseedin( 1 )
716 WRITE( nout, fmt = 9992 )iseedin( 2 )
717 WRITE( nout, fmt = 9991 )iseedin( 3 )
718 WRITE( nout, fmt = 9990 )iseedin( 4 )
719 IF( lsame( uplo, 'L' ) ) THEN
720 WRITE( nout, fmt = 9994 )' UPLO= ''L'' '
721 ELSE
722 WRITE( nout, fmt = 9994 )' UPLO= ''U'' '
723 END IF
724 IF( lsame( subtests, 'Y' ) ) THEN
725 WRITE( nout, fmt = 9994 )' SUBTESTS= ''Y'' '
726 ELSE
727 WRITE( nout, fmt = 9994 )' SUBTESTS= ''N'' '
728 END IF
729 WRITE( nout, fmt = 9989 )n
730 WRITE( nout, fmt = 9988 )nprow
731 WRITE( nout, fmt = 9987 )npcol
732 WRITE( nout, fmt = 9986 )nb
733 WRITE( nout, fmt = 9985 )mattype
734 WRITE( nout, fmt = 9982 )abstol
735 WRITE( nout, fmt = 9981 )thresh
736 WRITE( nout, fmt = 9994 )'C '
737 END IF
738 END IF
739*
740 CALL slcombine( context, 'All', '>', 'W', 6, 1, wtime )
741 CALL slcombine( context, 'All', '>', 'C', 6, 1, ctime )
742 IF( iam.EQ.0 ) THEN
743 IF( info.EQ.0 .OR. info.EQ.1 ) THEN
744 IF( wtime( 1 ).GE.0.0 ) THEN
745 WRITE( nout, fmt = 9999 )n, nb, nprow, npcol, mattype,
746 $ subtests, wtime( 1 ), ctime( 1 ), maxtstnrm,
747 $ maxqtqnrm, passed
748 ELSE
749 WRITE( nout, fmt = 9998 )n, nb, nprow, npcol, mattype,
750 $ subtests, ctime( 1 ), maxtstnrm, maxqtqnrm, passed
751 END IF
752 ELSE IF( info.EQ.2 ) THEN
753 IF( wtime( 1 ).GE.0.0 ) THEN
754 WRITE( nout, fmt = 9997 )n, nb, nprow, npcol, mattype,
755 $ subtests, wtime( 1 ), ctime( 1 )
756 ELSE
757 WRITE( nout, fmt = 9996 )n, nb, nprow, npcol, mattype,
758 $ subtests, ctime( 1 )
759 END IF
760 ELSE IF( info.EQ.3 ) THEN
761 WRITE( nout, fmt = 9995 )n, nb, nprow, npcol, mattype,
762 $ subtests
763 END IF
764C WRITE(*,*)'************************************************'
765 END IF
766*
767
768 RETURN
769 9999 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 1x,
770 $ f8.2, 1x, f8.2, 1x, g9.2, 1x, g9.2, 1x, a14 )
771 9998 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 1x, 8x,
772 $ 1x, f8.2, 1x, g9.2, 1x, g9.2, a14 )
773 9997 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 1x, f8.2,
774 $ 1x, f8.2, 21x, 'Bypassed' )
775 9996 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 1x, 8x,
776 $ 1x, f8.2, 21x, 'Bypassed' )
777 9995 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 32x,
778 $ 'Bad MEMORY parameters' )
779 9994 FORMAT( a )
780 9993 FORMAT( ' ISEED( 1 ) =', i8 )
781 9992 FORMAT( ' ISEED( 2 ) =', i8 )
782 9991 FORMAT( ' ISEED( 3 ) =', i8 )
783 9990 FORMAT( ' ISEED( 4 ) =', i8 )
784 9989 FORMAT( ' N=', i8 )
785 9988 FORMAT( ' NPROW=', i8 )
786 9987 FORMAT( ' NPCOL=', i8 )
787 9986 FORMAT( ' NB=', i8 )
788 9985 FORMAT( ' MATTYPE=', i8 )
789C 9984 FORMAT( ' IBTYPE=', I8 )
790C 9983 FORMAT( ' SUBTESTS=', A1 )
791 9982 FORMAT( ' ABSTOL=', d16.6 )
792 9981 FORMAT( ' THRESH=', d16.6 )
793C 9980 FORMAT( ' Increase TOTMEM in PDSEPRDRIVER' )
794*
795* End of PDSEPRTST
796*
pdmatgen
subroutine pdmatgen(ictxt, aform, diag, m, n, mb, nb, a, lda, iarow, iacol, iseed, iroff, irnum, icoff, icnum, myrow, mycol, nprow, npcol)
Definition pdmatgen.f:4
dlatms
subroutine dlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)
Definition dlatms.f:3
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition numroc.f:2
max
#define max(A, B)
Definition pcgemr.c:180
min
#define min(A, B)
Definition pcgemr.c:181
pdlaset
subroutine pdlaset(uplo, m, n, alpha, beta, a, ia, ja, desca)
Definition pdblastst.f:6862
pdlamch
double precision function pdlamch(ictxt, cmach)
Definition pdblastst.f:6769
pdchekpad
subroutine pdchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
Definition pdchekpad.f:3
pdelset
subroutine pdelset(a, ia, ja, desca, alpha)
Definition pdelset.f:2
pdfillpad
subroutine pdfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition pdfillpad.f:2
pdlasizesepr
subroutine pdlasizesepr(desca, iprepad, ipostpad, sizemqrleft, sizemqrright, sizeqrf, sizetms, sizeqtq, sizechk, sizesyevr, isizesyevr, sizesubtst, isizesubtst, sizetst, isizetst)
Definition pdlasizesepr.f:6
pdlasizesyevr
subroutine pdlasizesyevr(wknown, range, n, desca, vl, vu, il, iu, iseed, win, maxsize, vecsize, valsize)
Definition pdlasizesyevr.f:3
pdlatms
subroutine pdlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, ia, ja, desca, order, work, lwork, info)
Definition pdlatms.f:6
pdseprsubtst
subroutine pdseprsubtst(wknown, jobz, range, uplo, n, vl, vu, il, iu, thresh, abstol, a, copya, z, ia, ja, desca, win, wnew, ifail, iclustr, gap, iprepad, ipostpad, work, lwork, lwork1, iwork, liwork, result, tstnrm, qtqnrm, nout)
Definition pdseprsubtst.f:7
slcombine
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)
Definition sltimer.f:267
lsame
logical function lsame(ca, cb)
Definition tools.f:1724
dlaran
double precision function dlaran(iseed)
Definition tools.f:2000
Here is the call graph for this function:
Here is the caller graph for this function: