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