8
9
10
11
12
13
14
15 CHARACTER SUBTESTS, UPLO
16 INTEGER INFO, IPOSTPAD, IPREPAD, LDA, LIWORK, LRWORK,
17 $ LWORK, MATTYPE, N, NOUT, ORDER
18 DOUBLE PRECISION ABSTOL, THRESH
19
20
21 INTEGER DESCA( * ), ICLUSTR( * ), IFAIL( * ),
22 $ ISEED( 4 ), IWORK( * )
23 DOUBLE PRECISION GAP( * ), RWORK( * ), WIN( * ), WNEW( * )
24 COMPLEX*16 A( LDA, * ), COPYA( LDA, * ), WORK( * ),
25 $ Z( LDA, * )
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205 INTEGER BLOCK_CYCLIC_2D, DLEN_, DTYPE_, CTXT_, M_, N_,
206 $ MB_, NB_, RSRC_, CSRC_, LLD_
207 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
208 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
209 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
210 DOUBLE PRECISION ZERO, ONE, TEN, HALF
211 parameter( zero = 0.0d+0, one = 1.0d+0, ten = 10.0d+0,
212 $ half = 0.5d+0 )
213 COMPLEX*16 PADVAL
214 parameter( padval = ( 19.25d+0, 1.1d+1 ) )
215 COMPLEX*16 ZZERO
216 parameter( zzero = ( 0.0d+0, 0.0d+0 ) )
217 COMPLEX*16 ZONE
218 parameter( zone = ( 1.0d+0, 0.0d+0 ) )
219 INTEGER MAXTYP
220 parameter( maxtyp = 22 )
221
222
223
224 LOGICAL WKNOWN
225 CHARACTER JOBZ, RANGE
226 CHARACTER*14 PASSED
227 INTEGER CONTEXT, I, IAM, IINFO, IL, IMODE, IN, INDD,
228 $ INDRWORK, INDWORK, ISIZEHEEVX, ISIZESUBTST,
229 $ ISIZETST, ITYPE, IU, J, LHEEVXSIZE, LLRWORK,
230 $ LLWORK, MAXSIZE, MYCOL, MYROW, NB, NGEN, NLOC,
231 $ NNODES, NP, NPCOL, NPROW, NQ, RES, RSIZECHK,
232 $ RSIZEHEEVX, RSIZEQTQ, RSIZESUBTST, RSIZETST,
233 $ SIZEHEEVX, SIZEMQRLEFT, SIZEMQRRIGHT, SIZEQRF,
234 $ SIZESUBTST, SIZETMS, SIZETST, VALSIZE, VECSIZE,
235 $ SIZEHEEVD, RSIZEHEEVD, ISIZEHEEVD, NQ0, NP0,
236 $ LHEEVDSIZE
237 DOUBLE PRECISION ANINV, ANORM, COND, MAXQTQNRM, MAXTSTNRM, OVFL,
238 $ QTQNRM, RTOVFL, RTUNFL, TEMP1, TSTNRM, ULP,
239 $ ULPINV, UNFL, VL, VU
240
241
242 INTEGER ISEEDIN( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
243 $ KTYPE( MAXTYP )
244 DOUBLE PRECISION CTIME( 10 ), WTIME( 10 )
245
246
247 LOGICAL LSAME
248 INTEGER NUMROC
249 DOUBLE PRECISION DLARAN, PDLAMCH
251
252
253 EXTERNAL blacs_gridinfo, blacs_pinfo, dlabad, dlasrt,
258
259
260 INTRINSIC abs, dble, int,
max,
min, sqrt
261
262
263 DATA ktype / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
264 $ 8, 8, 9, 9, 9, 9, 9, 10, 11 /
265 DATA kmagn / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
266 $ 2, 3, 1, 1, 1, 2, 3, 1, 1 /
267 DATA kmode / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
268 $ 0, 0, 4, 3, 1, 4, 4, 3, 0 /
269
270
271
272 IF( block_cyclic_2d*csrc_*ctxt_*dlen_*dtype_*lld_*mb_*m_*nb_*n_*
273 $ rsrc_.LT.0 )RETURN
274
275 info = 0
276 passed = 'PASSED EVX'
277 context = desca( ctxt_ )
278 nb = desca( nb_ )
279
280 CALL blacs_pinfo( iam, nnodes )
281 CALL blacs_gridinfo( context, nprow, npcol, myrow, mycol )
282
283
284
285
286
287 CALL pzlasizesep( desca, iprepad, ipostpad, sizemqrleft,
288 $ sizemqrright, sizeqrf, sizetms, rsizeqtq,
289 $ rsizechk, sizeheevx, rsizeheevx, isizeheevx,
290 $ sizeheevd, rsizeheevd, isizeheevd,
291 $ sizesubtst, rsizesubtst, isizesubtst, sizetst,
292 $ rsizetst, isizetst )
293
294 IF( lrwork.LT.rsizetst ) THEN
295 info = 3
296 END IF
297
298 CALL igamx2d( context, 'a', ' ', 1, 1, info, 1, 1, 1, -1, -1, 0 )
299
300 IF( info.EQ.0 ) THEN
301
302 indd = 1
303 indrwork = indd + n
304 indwork = 1
305 llwork = lwork - indwork + 1
306 llrwork = lrwork - indrwork + 1
307
309 ulpinv = one / ulp
310 unfl =
pdlamch( context,
'Safe min' )
311 ovfl = one / unfl
312 CALL dlabad( unfl, ovfl )
313 rtunfl = sqrt( unfl )
314 rtovfl = sqrt( ovfl )
315 aninv = one / dble(
max( 1, n ) )
316
317
318
319 IF( myrow.EQ.0 .AND. mycol.EQ.0 ) THEN
320 CALL igebs2d( context, 'a', ' ', 4, 1, iseed, 4 )
321 ELSE
322 CALL igebr2d( context, 'a', ' ', 4, 1, iseed, 4, 0, 0 )
323 END IF
324 iseedin( 1 ) = iseed( 1 )
325 iseedin( 2 ) = iseed( 2 )
326 iseedin( 3 ) = iseed( 3 )
327 iseedin( 4 ) = iseed( 4 )
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346 itype = ktype( mattype )
347 imode = kmode( mattype )
348
349
350
351 GO TO ( 10, 20, 30 )kmagn( mattype )
352
353 10 CONTINUE
354 anorm = one
355 GO TO 40
356
357 20 CONTINUE
358 anorm = ( rtovfl*ulp )*aninv
359 GO TO 40
360
361 30 CONTINUE
362 anorm = rtunfl*n*ulpinv
363 GO TO 40
364
365 40 CONTINUE
366 IF( mattype.LE.15 ) THEN
367 cond = ulpinv
368 ELSE
369 cond = ulpinv*aninv / ten
370 END IF
371
372
373
374
375
376
377 IF( itype.EQ.1 ) THEN
378
379
380
381 DO 50 i = 1, n
382 rwork( indd+i-1 ) = zero
383 50 CONTINUE
384 CALL pzlaset(
'All', n, n, zzero, zzero, copya, 1, 1,
385 $ desca )
386 wknown = .true.
387
388 ELSE IF( itype.EQ.2 ) THEN
389
390
391
392 DO 60 i = 1, n
393 rwork( indd+i-1 ) = one
394 60 CONTINUE
395 CALL pzlaset(
'All', n, n, zzero, zone, copya, 1, 1, desca )
396 wknown = .true.
397
398 ELSE IF( itype.EQ.4 ) THEN
399
400
401
402 CALL pzfillpad( desca( ctxt_ ), sizetms, 1, work( indwork ),
403 $ sizetms, iprepad, ipostpad, padval+1.0d+0 )
404
405 CALL pzlatms( n, n,
'S', iseed,
'S', rwork( indd ), imode,
406 $ cond, anorm, 0, 0, 'N', copya, 1, 1, desca,
407 $ order, work( indwork+iprepad ), sizetms,
408 $ iinfo )
409 wknown = .true.
410
411 CALL pzchekpad( desca( ctxt_ ),
'PZLATMS1-WORK', sizetms, 1,
412 $ work( indwork ), sizetms, iprepad, ipostpad,
413 $ padval+1.0d+0 )
414
415 ELSE IF( itype.EQ.5 ) THEN
416
417
418
419 CALL pzfillpad( desca( ctxt_ ), sizetms, 1, work( indwork ),
420 $ sizetms, iprepad, ipostpad, padval+2.0d+0 )
421
422 CALL pzlatms( n, n,
'S', iseed,
'S', rwork( indd ), imode,
423 $ cond, anorm, n, n, 'N', copya, 1, 1, desca,
424 $ order, work( indwork+iprepad ), sizetms,
425 $ iinfo )
426
427 CALL pzchekpad( desca( ctxt_ ),
'PZLATMS2-WORK', sizetms, 1,
428 $ work( indwork ), sizetms, iprepad, ipostpad,
429 $ padval+2.0d+0 )
430
431 wknown = .true.
432
433 ELSE IF( itype.EQ.8 ) THEN
434
435
436
437 np =
numroc( n, desca( mb_ ), myrow, 0, nprow )
438 nq =
numroc( n, desca( nb_ ), mycol, 0, npcol )
439 CALL pzmatgen( desca( ctxt_ ),
'H',
'N', n, n, desca( mb_ ),
440 $ desca( nb_ ), copya, desca( lld_ ),
441 $ desca( rsrc_ ), desca( csrc_ ), iseed( 1 ),
442 $ 0, np, 0, nq, myrow, mycol, nprow, npcol )
443 info = 0
444 wknown = .false.
445
446 ELSE IF( itype.EQ.9 ) THEN
447
448
449
450
451 CALL pzfillpad( desca( ctxt_ ), sizetms, 1, work( indwork ),
452 $ sizetms, iprepad, ipostpad, padval+3.0d+0 )
453
454 CALL pzlatms( n, n,
'S', iseed,
'S', rwork( indd ), imode,
455 $ cond, anorm, n, n, 'N', copya, 1, 1, desca,
456 $ order, work( indwork+iprepad ), sizetms,
457 $ iinfo )
458
459 wknown = .true.
460
461 CALL pzchekpad( desca( ctxt_ ),
'PZLATMS3-WORK', sizetms, 1,
462 $ work( indwork ), sizetms, iprepad, ipostpad,
463 $ padval+3.0d+0 )
464
465 ELSE IF( itype.EQ.10 ) THEN
466
467
468
469
470 CALL pzlaset(
'All', n, n, zzero, zzero, copya, 1, 1,
471 $ desca )
472 np =
numroc( n, desca( mb_ ), 0, 0, nprow )
473 nq =
numroc( n, desca( nb_ ), 0, 0, npcol )
475 ngen = 0
476 70 CONTINUE
477
478 IF( ngen.LT.n ) THEN
479 in =
min( 1+int(
dlaran( iseed )*dble( nloc ) ), n-ngen )
480
481 CALL zlatms( in, in,
'S', iseed,
'P', rwork( indd ),
482 $ imode, cond, anorm, 1, 1, 'N', a, lda,
483 $ work( indwork ), iinfo )
484
485 DO 80 i = 2, in
486 temp1 = abs( a( i-1, i ) ) /
487 $ sqrt( abs( a( i-1, i-1 )*a( i, i ) ) )
488 IF( temp1.GT.half ) THEN
489 a( i-1, i ) = half*sqrt( abs( a( i-1, i-1 )*a( i,
490 $ i ) ) )
491 a( i, i-1 ) = a( i-1, i )
492 END IF
493 80 CONTINUE
494 CALL pzelset( copya, ngen+1, ngen+1, desca, a( 1, 1 ) )
495 DO 90 i = 2, in
496 CALL pzelset( copya, ngen+i, ngen+i, desca,
497 $ a( i, i ) )
498 CALL pzelset( copya, ngen+i-1, ngen+i, desca,
499 $ a( i-1, i ) )
500 CALL pzelset( copya, ngen+i, ngen+i-1, desca,
501 $ a( i, i-1 ) )
502 90 CONTINUE
503 ngen = ngen + in
504 GO TO 70
505 END IF
506 wknown = .false.
507
508 ELSE IF( itype.EQ.11 ) THEN
509
510
511
512 ngen = 0
513 j = 1
514 temp1 = zero
515 100 CONTINUE
516 IF( ngen.LT.n ) THEN
517 in =
min( j, n-ngen )
518 DO 110 i = 0, in - 1
519 rwork( indd+ngen+i ) = temp1
520 110 CONTINUE
521 temp1 = temp1 + one
522 j = 2*j
523 ngen = ngen + in
524 GO TO 100
525 END IF
526
527
528 CALL pzfillpad( desca( ctxt_ ), sizetms, 1, work( indwork ),
529 $ sizetms, iprepad, ipostpad, padval+4.0d+0 )
530
531 CALL pzlatms( n, n,
'S', iseed,
'S', rwork( indd ), imode,
532 $ cond, anorm, 0, 0, 'N', copya, 1, 1, desca,
533 $ order, work( indwork+iprepad ), sizetms,
534 $ iinfo )
535
536 CALL pzchekpad( desca( ctxt_ ),
'PZLATMS4-WORK', sizetms, 1,
537 $ work( indwork ), sizetms, iprepad, ipostpad,
538 $ padval+4.0d+0 )
539
540
541
542
543 wknown = .true.
544 ELSE
545 iinfo = 1
546 END IF
547
548 IF( wknown )
549 $ CALL dlasrt( 'I', n, rwork( indd ), iinfo )
550
551
552
553
554 il = -1
555 iu = -2
556 vl = one
557 vu = -one
558
560 $ iseed, rwork( indd ), maxsize, vecsize,
561 $ valsize )
562
563 lheevxsize =
min( maxsize, llrwork )
564
565 CALL pzsepsubtst( wknown,
'v',
'a', uplo, n, vl, vu, il, iu,
566 $ thresh, abstol, a, copya, z, 1, 1, desca,
567 $ rwork( indd ), win, ifail, iclustr, gap,
568 $ iprepad, ipostpad, work( indwork ), llwork,
569 $ rwork( indrwork ), llrwork, lheevxsize,
570 $ iwork, isizeheevx, res, tstnrm, qtqnrm,
571 $ nout )
572
573
574
575 maxtstnrm = tstnrm
576 maxqtqnrm = qtqnrm
577
578 res =0
579 IF( thresh.LE.zero ) THEN
580 passed = 'SKIPPED '
581 info = 2
582 ELSE IF( res.NE.0 ) THEN
583 passed = 'FAILED '
584 info = 1
585 END IF
586 END IF
587
588 IF( thresh.GT.zero .AND.
lsame( subtests,
'Y' ) )
THEN
589
590
591
592 IF( info.EQ.0 ) THEN
593
594 jobz = 'V'
595 range = 'A'
597 $ iseed, win( 1+iprepad ), maxsize,
598 $ vecsize, valsize )
599
600 lheevxsize = vecsize
601
602 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
603 $ iu, thresh, abstol, a, copya, z, 1, 1,
604 $ desca, win( 1+iprepad ), wnew, ifail,
605 $ iclustr, gap, iprepad, ipostpad,
606 $ work( indwork ), llwork, rwork, lrwork,
607 $ lheevxsize, iwork, isizeheevx, res,
608 $ tstnrm, qtqnrm, nout )
609
610 IF( res.NE.0 ) THEN
611 passed = 'FAILED stest 1'
612 maxtstnrm =
max( tstnrm, maxtstnrm )
613 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
614 info = 1
615 END IF
616 END IF
617
618
619
620 IF( info.EQ.0 ) THEN
621 jobz = 'V'
622 range = 'A'
624 $ iseed, win( 1+iprepad ), maxsize,
625 $ vecsize, valsize )
626
627 lheevxsize = vecsize + int(
dlaran( iseed )*
628 $ dble( maxsize-vecsize ) )
629
630 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
631 $ iu, thresh, abstol, a, copya, z, 1, 1,
632 $ desca, win( 1+iprepad ), wnew, ifail,
633 $ iclustr, gap, iprepad, ipostpad,
634 $ work( indwork ), llwork, rwork, lrwork,
635 $ lheevxsize, iwork, isizeheevx, res,
636 $ tstnrm, qtqnrm, nout )
637
638 IF( res.NE.0 ) THEN
639 passed = 'FAILED stest 2'
640 maxtstnrm =
max( tstnrm, maxtstnrm )
641 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
642 info = 1
643 END IF
644 END IF
645
646
647
648 IF( info.EQ.0 ) THEN
649
650 jobz = 'N'
651 range = 'A'
653 $ iseed, win( 1+iprepad ), maxsize,
654 $ vecsize, valsize )
655
656 lheevxsize = valsize
657 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
658 $ iu, thresh, abstol, a, copya, z, 1, 1,
659 $ desca, win( 1+iprepad ), wnew, ifail,
660 $ iclustr, gap, iprepad, ipostpad,
661 $ work( indwork ), llwork, rwork, lrwork,
662 $ lheevxsize, iwork, isizeheevx, res,
663 $ tstnrm, qtqnrm, nout )
664
665 IF( res.NE.0 ) THEN
666 maxtstnrm =
max( tstnrm, maxtstnrm )
667 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
668 passed = 'FAILED stest 3'
669 info = 1
670 END IF
671 END IF
672
673
674
675 IF( info.EQ.0 ) THEN
676
677 il = -1
678 iu = -1
679 jobz = 'N'
680 range = 'I'
681
682
683
685 $ iseed, win( 1+iprepad ), maxsize,
686 $ vecsize, valsize )
687
688 lheevxsize = valsize
689
690 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
691 $ iu, thresh, abstol, a, copya, z, 1, 1,
692 $ desca, win( 1+iprepad ), wnew, ifail,
693 $ iclustr, gap, iprepad, ipostpad,
694 $ work( indwork ), llwork, rwork, lrwork,
695 $ lheevxsize, iwork, isizeheevx, res,
696 $ tstnrm, qtqnrm, nout )
697
698 IF( res.NE.0 ) THEN
699 maxtstnrm =
max( tstnrm, maxtstnrm )
700 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
701 passed = 'FAILED stest 4'
702 info = 1
703 END IF
704 END IF
705
706
707
708 IF( info.EQ.0 ) THEN
709
710 il = -1
711 iu = -1
712 jobz = 'V'
713 range = 'I'
714
715
716
718 $ iseed, win( 1+iprepad ), maxsize,
719 $ vecsize, valsize )
720
721 lheevxsize = maxsize
722
723 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
724 $ iu, thresh, abstol, a, copya, z, 1, 1,
725 $ desca, win( 1+iprepad ), wnew, ifail,
726 $ iclustr, gap, iprepad, ipostpad,
727 $ work( indwork ), llwork, rwork, lrwork,
728 $ lheevxsize, iwork, isizeheevx, res,
729 $ tstnrm, qtqnrm, nout )
730
731 IF( res.NE.0 ) THEN
732 maxtstnrm =
max( tstnrm, maxtstnrm )
733 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
734 passed = 'FAILED stest 5'
735 info = 1
736 END IF
737 END IF
738
739
740
741 IF( info.EQ.0 ) THEN
742 il = -1
743 iu = -1
744 jobz = 'V'
745 range = 'I'
746
747
748
750 $ iseed, win( 1+iprepad ), maxsize,
751 $ vecsize, valsize )
752
753 lheevxsize = vecsize
754
755 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
756 $ iu, thresh, abstol, a, copya, z, 1, 1,
757 $ desca, win( 1+iprepad ), wnew, ifail,
758 $ iclustr, gap, iprepad, ipostpad,
759 $ work( indwork ), llwork, rwork, lrwork,
760 $ lheevxsize, iwork, isizeheevx, res,
761 $ tstnrm, qtqnrm, nout )
762
763 IF( res.NE.0 ) THEN
764 maxtstnrm =
max( tstnrm, maxtstnrm )
765 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
766 passed = 'FAILED stest 6'
767 info = 1
768 END IF
769 END IF
770
771
772
773 IF( info.EQ.0 ) THEN
774 il = -1
775 iu = -1
776 jobz = 'V'
777 range = 'I'
778
779
780
782 $ iseed, win( 1+iprepad ), maxsize,
783 $ vecsize, valsize )
784 lheevxsize = vecsize + int(
dlaran( iseed )*
785 $ dble( maxsize-vecsize ) )
786
787 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
788 $ iu, thresh, abstol, a, copya, z, 1, 1,
789 $ desca, win( 1+iprepad ), wnew, ifail,
790 $ iclustr, gap, iprepad, ipostpad,
791 $ work( indwork ), llwork, rwork, lrwork,
792 $ lheevxsize, iwork, isizeheevx, res,
793 $ tstnrm, qtqnrm, nout )
794
795 IF( res.NE.0 ) THEN
796 maxtstnrm =
max( tstnrm, maxtstnrm )
797 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
798 passed = 'FAILED stest 7'
799 info = 1
800 END IF
801 END IF
802
803
804
805 IF( info.EQ.0 ) THEN
806 vl = one
807 vu = -one
808 jobz = 'N'
809 range = 'V'
810
811
812
814 $ iseed, win( 1+iprepad ), maxsize,
815 $ vecsize, valsize )
816
817 lheevxsize = valsize
818
819 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
820 $ iu, thresh, abstol, a, copya, z, 1, 1,
821 $ desca, win( 1+iprepad ), wnew, ifail,
822 $ iclustr, gap, iprepad, ipostpad,
823 $ work( indwork ), llwork, rwork, lrwork,
824 $ lheevxsize, iwork, isizeheevx, res,
825 $ tstnrm, qtqnrm, nout )
826
827 IF( res.NE.0 ) THEN
828 maxtstnrm =
max( tstnrm, maxtstnrm )
829 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
830 passed = 'FAILED stest 8'
831 info = 1
832 END IF
833 END IF
834
835
836
837 IF( info.EQ.0 ) THEN
838 vl = one
839 vu = -one
840 jobz = 'V'
841 range = 'V'
842
843
844
846 $ iseed, win( 1+iprepad ), maxsize,
847 $ vecsize, valsize )
848
849 lheevxsize = maxsize
850
851 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
852 $ iu, thresh, abstol, a, copya, z, 1, 1,
853 $ desca, win( 1+iprepad ), wnew, ifail,
854 $ iclustr, gap, iprepad, ipostpad,
855 $ work( indwork ), llwork, rwork, lrwork,
856 $ lheevxsize, iwork, isizeheevx, res,
857 $ tstnrm, qtqnrm, nout )
858
859 IF( res.NE.0 ) THEN
860 maxtstnrm =
max( tstnrm, maxtstnrm )
861 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
862 passed = 'FAILED stest 9'
863 info = 1
864 END IF
865 END IF
866
867
868
869
870 IF( info.EQ.0 ) THEN
871 vl = one
872 vu = -one
873 jobz = 'V'
874 range = 'V'
875
876
877
879 $ iseed, win( 1+iprepad ), maxsize,
880 $ vecsize, valsize )
881
882 lheevxsize = vecsize
883
884 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
885 $ iu, thresh, abstol, a, copya, z, 1, 1,
886 $ desca, win( 1+iprepad ), wnew, ifail,
887 $ iclustr, gap, iprepad, ipostpad,
888 $ work( indwork ), llwork, rwork, lrwork,
889 $ lheevxsize, iwork, isizeheevx, res,
890 $ tstnrm, qtqnrm, nout )
891
892 IF( res.NE.0 ) THEN
893 maxtstnrm =
max( tstnrm, maxtstnrm )
894 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
895 passed = 'FAILED stest10'
896 info = 1
897 END IF
898 END IF
899
900
901
902
903
904 IF( info.EQ.0 ) THEN
905 vl = one
906 vu = -one
907 jobz = 'V'
908 range = 'V'
909
910
911
913 $ iseed, win( 1+iprepad ), maxsize,
914 $ vecsize, valsize )
915
916
917 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
918 $ iu, thresh, abstol, a, copya, z, 1, 1,
919 $ desca, win( 1+iprepad ), wnew, ifail,
920 $ iclustr, gap, iprepad, ipostpad,
921 $ work( indwork ), llwork, rwork, lrwork,
922 $ lheevxsize, iwork, isizeheevx, res,
923 $ tstnrm, qtqnrm, nout )
924
925 IF( res.NE.0 ) THEN
926 maxtstnrm =
max( tstnrm, maxtstnrm )
927 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
928 passed = 'FAILED stest11'
929 info = 1
930 END IF
931 END IF
932
933
934
935
936 IF( info.EQ.0 ) THEN
937 vl = one
938 vu = -one
939 jobz = 'V'
940 range = 'V'
941
942
943
945 $ iseed, win( 1+iprepad ), maxsize,
946 $ vecsize, valsize )
947
948 lheevxsize = valsize
949
950 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
951 $ iu, thresh, abstol, a, copya, z, 1, 1,
952 $ desca, win( 1+iprepad ), wnew, ifail,
953 $ iclustr, gap, iprepad, ipostpad,
954 $ work( indwork ), llwork, rwork, lrwork,
955 $ lheevxsize, iwork, isizeheevx, res,
956 $ tstnrm, qtqnrm, nout )
957
958 IF( res.NE.0 ) THEN
959 maxtstnrm =
max( tstnrm, maxtstnrm )
960 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
961 passed = 'FAILED stest12'
962 info = 1
963 END IF
964 END IF
965
966
967
968
969
970 IF( info.EQ.0 ) THEN
971 vl = one
972 vu = -one
973 jobz = 'V'
974 range = 'V'
975
976
977
979 $ iseed, win( 1+iprepad ), maxsize,
980 $ vecsize, valsize )
981
982
983 CALL pzsepsubtst( .true., jobz, range, uplo, n, vl, vu, il,
984 $ iu, thresh, abstol, a, copya, z, 1, 1,
985 $ desca, win( 1+iprepad ), wnew, ifail,
986 $ iclustr, gap, iprepad, ipostpad,
987 $ work( indwork ), llwork, rwork, lrwork,
988 $ lheevxsize, iwork, isizeheevx, res,
989 $ tstnrm, qtqnrm, nout )
990
991 IF( res.NE.0 ) THEN
992 maxtstnrm =
max( tstnrm, maxtstnrm )
993 maxqtqnrm =
max( qtqnrm, maxqtqnrm )
994 passed = 'FAILED stest13'
995 info = 1
996 END IF
997 END IF
998 END IF
999
1000
1001
1002 CALL igamx2d( context, 'All', ' ', 1, 1, info, 1, -1, -1, -1, -1,
1003 $ -1 )
1004
1005 IF( info.EQ.1 ) THEN
1006 IF( iam.EQ.0 ) THEN
1007 WRITE( nout, fmt = 9994 )'C '
1008 WRITE( nout, fmt = 9993 )iseedin( 1 )
1009 WRITE( nout, fmt = 9992 )iseedin( 2 )
1010 WRITE( nout, fmt = 9991 )iseedin( 3 )
1011 WRITE( nout, fmt = 9990 )iseedin( 4 )
1012 IF(
lsame( uplo,
'L' ) )
THEN
1013 WRITE( nout, fmt = 9994 )' UPLO= ''L'' '
1014 ELSE
1015 WRITE( nout, fmt = 9994 )' UPLO= ''U'' '
1016 END IF
1017 IF(
lsame( subtests,
'Y' ) )
THEN
1018 WRITE( nout, fmt = 9994 )' SUBTESTS= ''Y'' '
1019 ELSE
1020 WRITE( nout, fmt = 9994 )' SUBTESTS= ''N'' '
1021 END IF
1022 WRITE( nout, fmt = 9989 )n
1023 WRITE( nout, fmt = 9988 )nprow
1024 WRITE( nout, fmt = 9987 )npcol
1025 WRITE( nout, fmt = 9986 )nb
1026 WRITE( nout, fmt = 9985 )mattype
1027 WRITE( nout, fmt = 9982 )abstol
1028 WRITE( nout, fmt = 9981 )thresh
1029 WRITE( nout, fmt = 9994 )'C '
1030 END IF
1031 END IF
1032
1033 CALL slcombine( context,
'All',
'>',
'W', 6, 1, wtime )
1034 CALL slcombine( context,
'All',
'>',
'C', 6, 1, ctime )
1035 IF( iam.EQ.0 ) THEN
1036 IF( info.EQ.0 .OR. info.EQ.1 ) THEN
1037 IF( wtime( 1 ).GE.0.0 ) THEN
1038 WRITE( nout, fmt = 9999 )n, nb, nprow, npcol, mattype,
1039 $ subtests, wtime( 1 ), ctime( 1 ), maxtstnrm,
1040 $ maxqtqnrm, passed
1041 ELSE
1042 WRITE( nout, fmt = 9998 )n, nb, nprow, npcol, mattype,
1043 $ subtests, ctime( 1 ), maxtstnrm, maxqtqnrm, passed
1044 END IF
1045 ELSE IF( info.EQ.2 ) THEN
1046 IF( wtime( 1 ).GE.0.0 ) THEN
1047 WRITE( nout, fmt = 9997 )n, nb, nprow, npcol, mattype,
1048 $ subtests, wtime( 1 ), ctime( 1 )
1049 ELSE
1050 WRITE( nout, fmt = 9996 )n, nb, nprow, npcol, mattype,
1051 $ subtests, ctime( 1 )
1052 END IF
1053 ELSE IF( info.EQ.3 ) THEN
1054 WRITE( nout, fmt = 9995 )n, nb, nprow, npcol, mattype,
1055 $ subtests
1056 END IF
1057 END IF
1058
1059
1060
1061 passed = 'PASSED EEVD'
1062
1063
1064
1065 IF( info.EQ.0 ) THEN
1066
1067 np0 =
numroc( n, nb, 0, 0, nprow )
1068 nq0 =
numroc(
max( n, 1 ), nb, 0, 0, npcol )
1069 lheevdsize = 1 + 9*n + 3*np0*nq0
1070 isizeheevd =
max( 1, 2+7*n+8*npcol )
1071
1072 CALL pzsdpsubtst( wknown, uplo, n, thresh, abstol, a, copya, z,
1073 $ 1, 1, desca, win, wnew, iprepad, ipostpad,
1074 $ work( indwork ), llwork, rwork, lrwork,
1075 $ lheevdsize, iwork, isizeheevd, res, tstnrm,
1076 $ qtqnrm, nout )
1077
1078 maxtstnrm = tstnrm
1079 maxqtqnrm = qtqnrm
1080
1081 IF( res.NE.0 ) THEN
1082 passed = 'FAILED EEVD'
1083 info = 1
1084 END IF
1085 END IF
1086
1087
1088
1089 CALL igamx2d( context, 'All', ' ', 1, 1, info, 1, -1, -1, -1, -1,
1090 $ -1 )
1091
1092 IF( info.EQ.1 ) THEN
1093 IF( iam.EQ.0 ) THEN
1094 WRITE( nout, fmt = 9994 )'C '
1095 WRITE( nout, fmt = 9993 )iseedin( 1 )
1096 WRITE( nout, fmt = 9992 )iseedin( 2 )
1097 WRITE( nout, fmt = 9991 )iseedin( 3 )
1098 WRITE( nout, fmt = 9990 )iseedin( 4 )
1099 IF(
lsame( uplo,
'L' ) )
THEN
1100 WRITE( nout, fmt = 9994 )' UPLO= ''L'' '
1101 ELSE
1102 WRITE( nout, fmt = 9994 )' UPLO= ''U'' '
1103 END IF
1104 IF(
lsame( subtests,
'Y' ) )
THEN
1105 WRITE( nout, fmt = 9994 )' SUBTESTS= ''Y'' '
1106 ELSE
1107 WRITE( nout, fmt = 9994 )' SUBTESTS= ''N'' '
1108 END IF
1109 WRITE( nout, fmt = 9989 )n
1110 WRITE( nout, fmt = 9988 )nprow
1111 WRITE( nout, fmt = 9987 )npcol
1112 WRITE( nout, fmt = 9986 )nb
1113 WRITE( nout, fmt = 9985 )mattype
1114 WRITE( nout, fmt = 9982 )abstol
1115 WRITE( nout, fmt = 9981 )thresh
1116 WRITE( nout, fmt = 9994 )'C '
1117 END IF
1118 END IF
1119
1120 CALL slcombine( context,
'All',
'>',
'W', 6, 1, wtime )
1121 CALL slcombine( context,
'All',
'>',
'C', 6, 1, ctime )
1122 IF( iam.EQ.0 ) THEN
1123 IF( info.EQ.0 .OR. info.EQ.1 ) THEN
1124 IF( wtime( 1 ).GE.0.0 ) THEN
1125 WRITE( nout, fmt = 9999 )n, nb, nprow, npcol, mattype,
1126 $ subtests, wtime( 1 ), ctime( 1 ), maxtstnrm,
1127 $ maxqtqnrm, passed
1128 ELSE
1129 WRITE( nout, fmt = 9998 )n, nb, nprow, npcol, mattype,
1130 $ subtests, ctime( 1 ), maxtstnrm, maxqtqnrm, passed
1131 END IF
1132 ELSE IF( info.EQ.2 ) THEN
1133 IF( wtime( 1 ).GE.0.0 ) THEN
1134 WRITE( nout, fmt = 9997 )n, nb, nprow, npcol, mattype,
1135 $ subtests, wtime( 1 ), ctime( 1 )
1136 ELSE
1137 WRITE( nout, fmt = 9996 )n, nb, nprow, npcol, mattype,
1138 $ subtests, ctime( 1 )
1139 END IF
1140 ELSE IF( info.EQ.3 ) THEN
1141 WRITE( nout, fmt = 9995 )n, nb, nprow, npcol, mattype,
1142 $ subtests
1143 END IF
1144 END IF
1145 120 CONTINUE
1146
1147 RETURN
1148 9999 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 1x, f8.2,
1149 $ 1x, f8.2, 1x, g9.2, 1x, g9.2, 1x, a14 )
1150 9998 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 1x, 8x,
1151 $ 1x, f8.2, 1x, g9.2, 1x, g9.2, a14 )
1152 9997 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 1x, f8.2,
1153 $ 1x, f8.2, 21x, 'Bypassed' )
1154 9996 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 1x, 8x,
1155 $ 1x, f8.2, 21x, 'Bypassed' )
1156 9995 FORMAT( 1x, i5, 1x, i3, 1x, i3, 1x, i3, 1x, i3, 3x, a1, 32x,
1157 $ 'Bad MEMORY parameters' )
1158 9994 FORMAT( a )
1159 9993 FORMAT( ' ISEED( 1 ) =', i8 )
1160 9992 FORMAT( ' ISEED( 2 ) =', i8 )
1161 9991 FORMAT( ' ISEED( 3 ) =', i8 )
1162 9990 FORMAT( ' ISEED( 4 ) =', i8 )
1163 9989 FORMAT( ' N=', i8 )
1164 9988 FORMAT( ' NPROW=', i8 )
1165 9987 FORMAT( ' NPCOL=', i8 )
1166 9986 FORMAT( ' NB=', i8 )
1167 9985 FORMAT( ' MATTYPE=', i8 )
1168 9984 FORMAT( ' IBTYPE=', i8 )
1169 9983 FORMAT( ' SUBTESTS=', a1 )
1170 9982 FORMAT( ' ABSTOL=', d16.6 )
1171 9981 FORMAT( ' THRESH=', d16.6 )
1172 9980 FORMAT( ' Increase TOTMEM in PZSEPDRIVER' )
1173
1174
1175
subroutine pzmatgen(ictxt, aform, diag, m, n, mb, nb, a, lda, iarow, iacol, iseed, iroff, irnum, icoff, icnum, myrow, mycol, nprow, npcol)
integer function numroc(n, nb, iproc, isrcproc, nprocs)
double precision function pdlamch(ictxt, cmach)
subroutine pzlaset(uplo, m, n, alpha, beta, a, ia, ja, desca)
subroutine pzchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
subroutine pzelset(a, ia, ja, desca, alpha)
subroutine pzfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
subroutine pzlasizeheevx(wknown, range, n, desca, vl, vu, il, iu, iseed, win, maxsize, vecsize, valsize)
subroutine pzlasizesep(desca, iprepad, ipostpad, sizemqrleft, sizemqrright, sizeqrf, sizetms, rsizeqtq, rsizechk, sizeheevx, rsizeheevx, isizeheevx, sizeheevd, rsizeheevd, isizeheevd, sizesubtst, rsizesubtst, isizesubtst, sizetst, rsizetst, isizetst)
subroutine pzlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, ia, ja, desca, order, work, lwork, info)
subroutine pzsdpsubtst(wknown, uplo, n, thresh, abstol, a, copya, z, ia, ja, desca, win, wnew, iprepad, ipostpad, work, lwork, rwork, lrwork, lwork1, iwork, liwork, result, tstnrm, qtqnrm, nout)
subroutine pzsepsubtst(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)
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)
subroutine zlatms(m, n, dist, iseed, sym, d, mode, cond, dmax, kl, ku, pack, a, lda, work, info)