OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pzpbdriver.f
Go to the documentation of this file.
1 PROGRAM pzpbdriver
2*
3*
4* -- ScaLAPACK routine (version 1.7) --
5* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
6* and University of California, Berkeley.
7* November 15, 1997
8*
9* Purpose
10* =======
11*
12* PZPBDRIVER is a test program for the
13* ScaLAPACK Band Cholesky routines corresponding to the options
14* indicated by ZPB. This test driver performs an
15* A = L*L**H factorization
16* and solves a linear system with the factors for 1 or more RHS.
17*
18* The program must be driven by a short data file.
19* Here's an example file:
20*'ScaLAPACK, Version 1.2, banded linear systems input file'
21*'PVM.'
22*'' output file name (if any)
23*6 device out
24*'L' define Lower or Upper
25*9 number of problem sizes
26*1 5 17 28 37 121 200 1023 2048 3073 values of N
27*6 number of bandwidths
28*1 2 4 10 31 64 values of BW
29*1 number of NB's
30*-1 3 4 5 values of NB (-1 for automatic choice)
31*1 number of NRHS's (must be 1)
32*8 values of NRHS
33*1 number of NBRHS's (ignored)
34*1 values of NBRHS (ignored)
35*6 number of process grids
36*1 2 3 4 5 7 8 15 26 47 64 values of "Number of Process Columns"
37*3.0 threshold
38*
39* Internal Parameters
40* ===================
41*
42* TOTMEM INTEGER, default = 6200000.
43* TOTMEM is a machine-specific parameter indicating the
44* maximum amount of available memory in bytes.
45* The user should customize TOTMEM to his platform. Remember
46* to leave room in memory for the operating system, the BLACS
47* buffer, etc. For example, on a system with 8 MB of memory
48* per process (e.g., one processor on an Intel iPSC/860), the
49* parameters we use are TOTMEM=6200000 (leaving 1.8 MB for OS,
50* code, BLACS buffer, etc). However, for PVM, we usually set
51* TOTMEM = 2000000. Some experimenting with the maximum value
52* of TOTMEM may be required.
53*
54* INTGSZ INTEGER, default = 4 bytes.
55* ZPLXSZ INTEGER, default = 16 bytes.
56* INTGSZ and ZPLXSZ indicate the length in bytes on the
57* given platform for an integer and a double precision
58* complex.
59* MEM COMPLEX*16 array, dimension ( TOTMEM/ZPLXSZ )
60* All arrays used by ScaLAPACK routines are allocated from
61* this array and referenced by pointers. The integer IPB,
62* for example, is a pointer to the starting element of MEM for
63* the solution vector(s) B.
64*
65* =====================================================================
66*
67* Code Developer: Andrew J. Cleary, University of Tennessee.
68* Current address: Lawrence Livermore National Labs.
69* This version released: August, 2001.
70*
71* =====================================================================
72*
73* .. Parameters ..
74 INTEGER totmem
75 parameter( totmem = 3000000 )
76 INTEGER block_cyclic_2d, csrc_, ctxt_, dlen_, dtype_,
77 $ lld_, mb_, m_, nb_, n_, rsrc_
78 parameter( block_cyclic_2d = 1, dlen_ = 9, dtype_ = 1,
79 $ ctxt_ = 2, m_ = 3, n_ = 4, mb_ = 5, nb_ = 6,
80 $ rsrc_ = 7, csrc_ = 8, lld_ = 9 )
81*
82 DOUBLE PRECISION zero
83 INTEGER memsiz, ntests, zplxsz
84 COMPLEX*16 padval
85 parameter( zplxsz = 16,
86 $ memsiz = totmem / zplxsz, ntests = 20,
87 $ padval = ( -9923.0d+0, -9923.0d+0 ),
88 $ zero = 0.0d+0 )
89 INTEGER int_one
90 parameter( int_one = 1 )
91* ..
92* .. Local Scalars ..
93 LOGICAL check
94 CHARACTER uplo
95 CHARACTER*6 passed
96 CHARACTER*80 outfile
97 INTEGER bw, bw_num, fillin_size, free_ptr, h, HH, i,
98 $ iam, iaseed, ibseed, ictxt, ictxtb, ierr_temp,
99 $ imidpad, info, ipa, ipb, ipostpad, iprepad,
100 $ ipw, ipw_size, ipw_solve, ipw_solve_size,
101 $ ip_driver_w, ip_fillin, j, k, kfail, kpass,
102 $ kskip, ktests, mycol, myrhs_size, myrow, n, nb,
103 $ nbw, ngrids, nmat, nnb, nnbr, nnr, nout, np,
104 $ npcol, NPROCS, nprocs_real, nprow, nq, nrhs,
105 $ n_first, n_last, worksiz
106 REAL thresh
107 DOUBLE PRECISION anorm, nops, nops2, sresid, tmflops,
108 $ tmflops2
109* ..
110* .. Local Arrays ..
111 INTEGER bwval( ntests ), desca( 7 ), desca2d( dlen_ ),
112 $ descb( 7 ), descb2d( dlen_ ), ierr( 1 ),
113 $ nbrval( ntests ), nbval( ntests ),
114 $ nrval( ntests ), nval( ntests ),
115 $ pval( ntests ), qval( ntests )
116 DOUBLE PRECISION ctime( 2 ), wtime( 2 )
117 COMPLEX*16 mem( memsiz )
118* ..
119* .. External Subroutines ..
120 EXTERNAL blacs_barrier, blacs_exit, blacs_get,
121 $ blacs_gridexit, blacs_gridinfo, blacs_gridinit,
122 $ blacs_pinfo, descinit, igsum2d, pzbmatgen,
123 $ pzchekpad, pzfillpad, pzmatgen, pzpbinfo,
124 $ pzpblaschk, pzpbtrf, pzpbtrs, slboot,
125 $ slcombine, sltimer
126* ..
127* .. External Functions ..
128 INTEGER numroc
129 LOGICAL lsame
130 DOUBLE PRECISION pzlange
131 EXTERNAL lsame, numroc, pzlange
132* ..
133* .. Intrinsic Functions ..
134 INTRINSIC dble, max, min, mod
135* ..
136* .. Data Statements ..
137 DATA kfail, kpass, kskip, ktests / 4*0 /
138* ..
139*
140*
141*
142* .. Executable Statements ..
143*
144* Get starting information
145*
146 CALL blacs_pinfo( iam, nprocs )
147 iaseed = 100
148 ibseed = 200
149*
150 CALL pzpbinfo( outfile, nout, uplo, nmat, nval, ntests, nbw,
151 $ bwval, ntests, nnb, nbval, ntests, nnr, nrval,
152 $ ntests, nnbr, nbrval, ntests, ngrids, pval, ntests,
153 $ qval, ntests, thresh, mem, iam, nprocs )
154*
155 check = ( thresh.GE.0.0d+0 )
156*
157* Print headings
158*
159 IF( iam.EQ.0 ) THEN
160 WRITE( nout, fmt = * )
161 WRITE( nout, fmt = 9995 )
162 WRITE( nout, fmt = 9994 )
163 WRITE( nout, fmt = * )
164 END IF
165*
166* Loop over different process grids
167*
168 DO 60 i = 1, ngrids
169*
170 nprow = pval( i )
171 npcol = qval( i )
172*
173* Make sure grid information is correct
174*
175 ierr( 1 ) = 0
176 IF( nprow.LT.1 ) THEN
177 IF( iam.EQ.0 )
178 $ WRITE( nout, fmt = 9999 ) 'GRID', 'nprow', NPROW
179 IERR( 1 ) = 1
180.LT. ELSE IF( NPCOL1 ) THEN
181.EQ. IF( IAM0 )
182 $ WRITE( NOUT, FMT = 9999 ) 'grid', 'npcol', NPCOL
183 IERR( 1 ) = 1
184.GT. ELSE IF( NPROW*NPCOLNPROCS ) THEN
185.EQ. IF( IAM0 )
186 $ WRITE( NOUT, FMT = 9998 ) NPROW*NPCOL, NPROCS
187 IERR( 1 ) = 1
188 END IF
189*
190.GT. IF( IERR( 1 )0 ) THEN
191.EQ. IF( IAM0 )
192 $ WRITE( NOUT, FMT = 9997 ) 'grid'
193 KSKIP = KSKIP + 1
194 GO TO 50
195 END IF
196*
197* Define process grid
198*
199 CALL BLACS_GET( -1, 0, ICTXT )
200 CALL BLACS_GRIDINIT( ICTXT, 'row-major', NPROW, NPCOL )
201*
202*
203* Define transpose process grid
204*
205 CALL BLACS_GET( -1, 0, ICTXTB )
206 CALL BLACS_GRIDINIT( ICTXTB, 'column-major', NPCOL, NPROW )
207*
208* Go to bottom of process grid loop if this case doesn't use my
209* process
210*
211 CALL BLACS_GRIDINFO( ICTXT, NPROW, NPCOL, MYROW, MYCOL )
212*
213.LT..OR..LT. IF( MYROW0 MYCOL0 ) THEN
214 GO TO 50
215 ENDIF
216*
217 DO 40 J = 1, NMAT
218*
219 IERR( 1 ) = 0
220*
221 N = NVAL( J )
222*
223* Make sure matrix information is correct
224*
225.LT. IF( N1 ) THEN
226.EQ. IF( IAM0 )
227 $ WRITE( NOUT, FMT = 9999 ) 'matrix', 'n', N
228 IERR( 1 ) = 1
229 END IF
230*
231* Check all processes for an error
232*
233 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, IERR, 1,
234 $ -1, 0 )
235*
236.GT. IF( IERR( 1 )0 ) THEN
237.EQ. IF( IAM0 )
238 $ WRITE( NOUT, FMT = 9997 ) 'size'
239 KSKIP = KSKIP + 1
240 GO TO 40
241 END IF
242*
243*
244 DO 45 BW_NUM = 1, NBW
245*
246 IERR( 1 ) = 0
247*
248 BW = BWVAL( BW_NUM )
249.LT. IF( BW0 ) THEN
250.EQ. IF( IAM0 )
251 $ WRITE( NOUT, FMT = 9999 ) 'band', 'bw', BW
252 IERR( 1 ) = 1
253 END IF
254*
255.GT. IF( BWN-1 ) THEN
256 IERR( 1 ) = 1
257 END IF
258*
259* Check all processes for an error
260*
261 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, IERR, 1,
262 $ -1, 0 )
263*
264.GT. IF( IERR( 1 )0 ) THEN
265 KSKIP = KSKIP + 1
266 GO TO 45
267 END IF
268*
269 DO 30 K = 1, NNB
270*
271 IERR( 1 ) = 0
272*
273 NB = NBVAL( K )
274.LT. IF( NB0 ) THEN
275 NB =( (N-(NPCOL-1)*BW-1)/NPCOL + 1 )
276 $ + BW
277 NB = MAX( NB, 2*BW )
278 NB = MIN( N, NB )
279 END IF
280*
281* Make sure NB is legal
282*
283 IERR( 1 ) = 0
284.LT. IF( NBMIN( 2*BW, N ) ) THEN
285 IERR( 1 ) = 1
286 ENDIF
287*
288* Check all processes for an error
289*
290 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, IERR, 1,
291 $ -1, 0 )
292*
293.GT. IF( IERR( 1 )0 ) THEN
294 KSKIP = KSKIP + 1
295 GO TO 30
296 END IF
297*
298* Padding constants
299*
300 NP = NUMROC( (BW+1), (BW+1),
301 $ MYROW, 0, NPROW )
302 NQ = NUMROC( N, NB, MYCOL, 0, NPCOL )
303*
304 IF( CHECK ) THEN
305 IPREPAD = ((BW+1)+10)
306 IMIDPAD = 10
307 IPOSTPAD = ((BW+1)+10)
308 ELSE
309 IPREPAD = 0
310 IMIDPAD = 0
311 IPOSTPAD = 0
312 END IF
313*
314* Initialize the array descriptor for the matrix A
315*
316 CALL DESCINIT( DESCA2D, (BW+1), N,
317 $ (BW+1), NB, 0, 0,
318 $ ICTXT,((BW+1)+10), IERR( 1 ) )
319*
320* Convert this to 1D descriptor
321*
322 DESCA( 1 ) = 501
323 DESCA( 3 ) = N
324 DESCA( 4 ) = NB
325 DESCA( 5 ) = 0
326 DESCA( 2 ) = ICTXT
327 DESCA( 6 ) = ((BW+1)+10)
328 DESCA( 7 ) = 0
329*
330 IERR_TEMP = IERR( 1 )
331 IERR( 1 ) = 0
332 IERR( 1 ) = MIN( IERR( 1 ), IERR_TEMP )
333*
334* Check all processes for an error
335*
336 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, IERR, 1, -1, 0 )
337*
338.LT. IF( IERR( 1 )0 ) THEN
339.EQ. IF( IAM0 )
340 $ WRITE( NOUT, FMT = 9997 ) 'descriptor'
341 KSKIP = KSKIP + 1
342 GO TO 30
343 END IF
344*
345* Assign pointers into MEM for SCALAPACK arrays, A is
346* allocated starting at position MEM( IPREPAD+1 )
347*
348 FREE_PTR = 1
349 IPB = 0
350*
351* Save room for prepadding
352 FREE_PTR = FREE_PTR + IPREPAD
353*
354 IPA = FREE_PTR
355 FREE_PTR = FREE_PTR + DESCA2D( LLD_ )*
356 $ DESCA2D( NB_ )
357 $ + IPOSTPAD
358*
359* Add memory for fillin
360* Fillin space needs to store:
361* Fillin spike:
362* Contribution to previous proc's diagonal block of
363* reduced system:
364* Off-diagonal block of reduced system:
365* Diagonal block of reduced system:
366*
367 FILLIN_SIZE =
368 $ (NB+2*BW)*BW
369*
370* Claim memory for fillin
371*
372 FREE_PTR = FREE_PTR + IPREPAD
373 IP_FILLIN = FREE_PTR
374 FREE_PTR = FREE_PTR + FILLIN_SIZE
375*
376* Workspace needed by computational routines:
377*
378 IPW_SIZE = 0
379*
380* factorization:
381*
382 IPW_SIZE = BW*BW
383*
384* Claim memory for IPW
385*
386 IPW = FREE_PTR
387 FREE_PTR = FREE_PTR + IPW_SIZE
388*
389* Check for adequate memory for problem size
390*
391 IERR( 1 ) = 0
392.GT. IF( FREE_PTRMEMSIZ ) THEN
393.EQ. IF( IAM0 )
394 $ WRITE( NOUT, FMT = 9996 )
395 $ 'divide and conquer factorization',
396 $ (FREE_PTR )*ZPLXSZ
397 IERR( 1 ) = 1
398 END IF
399*
400* Check all processes for an error
401*
402 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, IERR,
403 $ 1, -1, 0 )
404*
405.GT. IF( IERR( 1 )0 ) THEN
406.EQ. IF( IAM0 )
407 $ WRITE( NOUT, FMT = 9997 ) 'memory'
408 KSKIP = KSKIP + 1
409 GO TO 30
410 END IF
411*
412* Worksize needed for LAPRNT
413 WORKSIZ = MAX( ((BW+1)+10), NB )
414*
415 IF( CHECK ) THEN
416*
417* Calculate the amount of workspace required by
418* the checking routines.
419*
420* PZLANGE
421 WORKSIZ = MAX( WORKSIZ, DESCA2D( NB_ ) )
422*
423* PZPBLASCHK
424 WORKSIZ = MAX( WORKSIZ,
425 $ MAX(5,MAX(BW*(BW+2),NB))+2*NB )
426 END IF
427*
428 FREE_PTR = FREE_PTR + IPREPAD
429 IP_DRIVER_W = FREE_PTR
430 FREE_PTR = FREE_PTR + WORKSIZ + IPOSTPAD
431*
432*
433* Check for adequate memory for problem size
434*
435 IERR( 1 ) = 0
436.GT. IF( FREE_PTRMEMSIZ ) THEN
437.EQ. IF( IAM0 )
438 $ WRITE( NOUT, FMT = 9996 ) 'factorization',
439 $ ( FREE_PTR )*ZPLXSZ
440 IERR( 1 ) = 1
441 END IF
442*
443* Check all processes for an error
444*
445 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1, IERR,
446 $ 1, -1, 0 )
447*
448.GT. IF( IERR( 1 )0 ) THEN
449.EQ. IF( IAM0 )
450 $ WRITE( NOUT, FMT = 9997 ) 'memory'
451 KSKIP = KSKIP + 1
452 GO TO 30
453 END IF
454*
455 CALL PZBMATGEN( ICTXT, UPLO, 'b', BW, BW, N, (BW+1), NB,
456 $ MEM( IPA ), ((BW+1)+10), 0, 0, IASEED,
457 $ MYROW, MYCOL, NPROW, NPCOL )
458*
459 CALL PZFILLPAD( ICTXT, NP, NQ, MEM( IPA-IPREPAD ),
460 $ ((BW+1)+10), IPREPAD, IPOSTPAD,
461 $ PADVAL )
462*
463 CALL PZFILLPAD( ICTXT, WORKSIZ, 1,
464 $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ,
465 $ IPREPAD, IPOSTPAD, PADVAL )
466*
467* Calculate norm of A for residual error-checking
468*
469 IF( CHECK ) THEN
470*
471 ANORM = PZLANGE( '1', (BW+1),
472 $ N, MEM( IPA ), 1, 1,
473 $ DESCA2D, MEM( IP_DRIVER_W ) )
474 CALL PZCHEKPAD( ICTXT, 'pzlange', NP, NQ,
475 $ MEM( IPA-IPREPAD ), ((BW+1)+10),
476 $ IPREPAD, IPOSTPAD, PADVAL )
477 CALL PZCHEKPAD( ICTXT, 'pzlange',
478 $ WORKSIZ, 1,
479 $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ,
480 $ IPREPAD, IPOSTPAD, PADVAL )
481 END IF
482*
483*
484 CALL SLBOOT()
485 CALL BLACS_BARRIER( ICTXT, 'all' )
486*
487* Perform factorization
488*
489 CALL SLTIMER( 1 )
490*
491 CALL PZPBTRF( UPLO, N, BW, MEM( IPA ), 1, DESCA,
492 $ MEM( IP_FILLIN ), FILLIN_SIZE, MEM( IPW ),
493 $ IPW_SIZE, INFO )
494*
495 CALL SLTIMER( 1 )
496*
497.NE. IF( INFO0 ) THEN
498.EQ. IF( IAM0 ) THEN
499 WRITE( NOUT, FMT = * ) 'pzpbtrf info=', INFO
500 ENDIF
501 KFAIL = KFAIL + 1
502 GO TO 30
503 END IF
504*
505 IF( CHECK ) THEN
506*
507* Check for memory overwrite in factorization
508*
509 CALL PZCHEKPAD( ICTXT, 'pzpbtrf', NP,
510 $ NQ, MEM( IPA-IPREPAD ), ((BW+1)+10),
511 $ IPREPAD, IPOSTPAD, PADVAL )
512 END IF
513*
514*
515* Loop over the different values for NRHS
516*
517 DO 20 HH = 1, NNR
518*
519 IERR( 1 ) = 0
520*
521 NRHS = NRVAL( HH )
522*
523* Initialize Array Descriptor for rhs
524*
525 CALL DESCINIT( DESCB2D, N, NRHS, NB, 1, 0, 0,
526 $ ICTXTB, NB+10, IERR( 1 ) )
527*
528* Convert this to 1D descriptor
529*
530 DESCB( 1 ) = 502
531 DESCB( 3 ) = N
532 DESCB( 4 ) = NB
533 DESCB( 5 ) = 0
534 DESCB( 2 ) = ICTXT
535 DESCB( 6 ) = DESCB2D( LLD_ )
536 DESCB( 7 ) = 0
537*
538* reset free_ptr to reuse space for right hand sides
539*
540.GT. IF( IPB 0 ) THEN
541 FREE_PTR = IPB
542 ENDIF
543*
544 FREE_PTR = FREE_PTR + IPREPAD
545 IPB = FREE_PTR
546 FREE_PTR = FREE_PTR + NRHS*DESCB2D( LLD_ )
547 $ + IPOSTPAD
548*
549* Allocate workspace for workspace in TRS routine:
550*
551 IPW_SOLVE_SIZE = (BW*NRHS)
552*
553 IPW_SOLVE = FREE_PTR
554 FREE_PTR = FREE_PTR + IPW_SOLVE_SIZE
555*
556 IERR( 1 ) = 0
557.GT. IF( FREE_PTRMEMSIZ ) THEN
558.EQ. IF( IAM0 )
559 $ WRITE( NOUT, FMT = 9996 )'solve',
560 $ ( FREE_PTR )*ZPLXSZ
561 IERR( 1 ) = 1
562 END IF
563*
564* Check all processes for an error
565*
566 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1,
567 $ IERR, 1, -1, 0 )
568*
569.GT. IF( IERR( 1 )0 ) THEN
570.EQ. IF( IAM0 )
571 $ WRITE( NOUT, FMT = 9997 ) 'memory'
572 KSKIP = KSKIP + 1
573 GO TO 15
574 END IF
575*
576 MYRHS_SIZE = NUMROC( N, NB, MYCOL, 0, NPCOL )
577*
578* Generate RHS
579*
580 CALL PZMATGEN(ICTXTB, 'no', 'no',
581 $ DESCB2D( M_ ), DESCB2D( N_ ),
582 $ DESCB2D( MB_ ), DESCB2D( NB_ ),
583 $ MEM( IPB ),
584 $ DESCB2D( LLD_ ), DESCB2D( RSRC_ ),
585 $ DESCB2D( CSRC_ ),
586 $ IBSEED, 0, MYRHS_SIZE, 0, NRHS, MYCOL,
587 $ MYROW, NPCOL, NPROW )
588*
589 IF( CHECK ) THEN
590 CALL PZFILLPAD( ICTXTB, NB, NRHS,
591 $ MEM( IPB-IPREPAD ),
592 $ DESCB2D( LLD_ ),
593 $ IPREPAD, IPOSTPAD,
594 $ PADVAL )
595 CALL PZFILLPAD( ICTXT, WORKSIZ, 1,
596 $ MEM( IP_DRIVER_W-IPREPAD ),
597 $ WORKSIZ, IPREPAD,
598 $ IPOSTPAD, PADVAL )
599 END IF
600*
601*
602 CALL BLACS_BARRIER( ICTXT, 'all')
603 CALL SLTIMER( 2 )
604*
605* Solve linear system via factorization
606*
607 CALL PZPBTRS( UPLO, N, BW, NRHS, MEM( IPA ), 1,
608 $ DESCA, MEM( IPB ), 1, DESCB,
609 $ MEM( IP_FILLIN ), FILLIN_SIZE,
610 $ MEM( IPW_SOLVE ), IPW_SOLVE_SIZE,
611 $ INFO )
612*
613 CALL SLTIMER( 2 )
614*
615.NE. IF( INFO0 ) THEN
616.EQ. IF( IAM0 )
617 $ WRITE( NOUT, FMT = * ) 'pzpbtrs info=', INFO
618 KFAIL = KFAIL + 1
619 PASSED = 'failed'
620 GO TO 20
621 END IF
622*
623 IF( CHECK ) THEN
624*
625* check for memory overwrite
626*
627 CALL PZCHEKPAD( ICTXT, 'pzpbtrs-work',
628 $ WORKSIZ, 1,
629 $ MEM( IP_DRIVER_W-IPREPAD ),
630 $ WORKSIZ, IPREPAD,
631 $ IPOSTPAD, PADVAL )
632*
633* check the solution to rhs
634*
635 SRESID = ZERO
636*
637 CALL PZPBLASCHK( 'h', UPLO, N, BW, BW, NRHS,
638 $ MEM( IPB ), 1, 1, DESCB2D,
639 $ IASEED, MEM( IPA ), 1, 1, DESCA2D,
640 $ IBSEED, ANORM, SRESID,
641 $ MEM( IP_DRIVER_W ), WORKSIZ )
642*
643.EQ. IF( IAM0 ) THEN
644.GT. IF( SRESIDTHRESH )
645 $ WRITE( NOUT, FMT = 9985 ) SRESID
646 END IF
647*
648* The second test is a NaN trap
649*
650.LE..AND. IF( ( SRESIDTHRESH )
651.EQ. $ ( (SRESID-SRESID)0.0D+0 ) ) THEN
652 KPASS = KPASS + 1
653 PASSED = 'passed'
654 ELSE
655 KFAIL = KFAIL + 1
656 PASSED = 'failed'
657 END IF
658*
659 END IF
660*
661 15 CONTINUE
662* Skipped tests jump to here to print out "SKIPPED"
663*
664* Gather maximum of all CPU and WALL clock timings
665*
666 CALL SLCOMBINE( ICTXT, 'all', '>', 'w', 2, 1,
667 $ WTIME )
668 CALL SLCOMBINE( ICTXT, 'all', '>', 'c', 2, 1,
669 $ CTIME )
670*
671* Print results
672*
673.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
674*
675 NOPS = 0
676 NOPS2 = 0
677*
678 N_FIRST = NB
679 NPROCS_REAL = ( N-1 )/NB + 1
680 N_LAST = MOD( N-1, NB ) + 1
681*
682*
683 NOPS = NOPS + DBLE(BW)*( -2.D0 / 3.D0+DBLE(BW)*
684 $ ( -1.D0+DBLE(BW)*( -1.D0 / 3.D0 ) ) ) +
685 $ DBLE(N)*( 1.D0+DBLE(BW)*( 3.D0 /
686 $ 2.D0+DBLE(BW)*( 1.D0 / 2.D0 ) ) )
687 NOPS = NOPS + DBLE(BW)*( -1.D0 / 6.D0+DBLE(BW)
688 $ *( -1.D0 /2.D0+DBLE(BW)
689 $ *( -1.D0 / 3.D0 ) ) ) +
690 $ DBLE(N)*( DBLE(BW) /
691 $ 2.D0*( 1.D0+DBLE(BW) ) )
692*
693 NOPS = NOPS +
694 $ DBLE(NRHS)*( ( 2*DBLE(N)-DBLE(BW) )*
695 $ ( DBLE(BW)+1.D0 ) )+ DBLE(NRHS)*
696 $ ( DBLE(BW)*( 2*DBLE(N)-
697 $ ( DBLE(BW)+1.D0 ) ) )
698*
699*
700* Second calc to represent actual hardware speed
701*
702* NB bw^2 flops for LLt factorization in 1st proc
703*
704 NOPS2 = ( (DBLE(N_FIRST))* DBLE(BW)**2 )
705*
706.GT. IF ( NPROCS_REAL 1) THEN
707* 4 NB bw^2 flops for LLt factorization and
708* spike calc in last processor
709*
710 NOPS2 = NOPS2 +
711 $ 4*( (DBLE(N_LAST)*DBLE(BW)**2) )
712 ENDIF
713*
714.GT. IF ( NPROCS_REAL 2) THEN
715* 4 NB bw^2 flops for LLt factorization and
716* spike calc in other processors
717*
718 NOPS2 = NOPS2 + (NPROCS_REAL-2)*
719 $ 4*( (DBLE(NB)*DBLE(BW)**2) )
720 ENDIF
721*
722* Reduced system
723*
724 NOPS2 = NOPS2 +
725 $ ( NPROCS_REAL-1 ) * ( BW*BW*BW/3 )
726.GT. IF( NPROCS_REAL 1 ) THEN
727 NOPS2 = NOPS2 +
728 $ ( NPROCS_REAL-2 ) * ( 2 * BW*BW*BW )
729 ENDIF
730*
731*
732* nrhs * 4 n_first*bw flops for LLt solve in proc 1.
733*
734 NOPS2 = NOPS2 +
735 $ ( 4.0D+0*(DBLE(N_FIRST)*DBLE(BW))*DBLE(NRHS) )
736*
737.GT. IF ( NPROCS_REAL 1 ) THEN
738*
739* 2*nrhs*4 n_last*bw flops for LLt solve in last.
740*
741 NOPS2 = NOPS2 +
742 $ 2*( 4.0D+0*(DBLE(N_LAST)*DBLE(BW))*DBLE(NRHS) )
743 ENDIF
744*
745.GT. IF ( NPROCS_REAL 2 ) THEN
746*
747* 2 * nrhs * 4 NB*bw flops for LLt solve in others.
748*
749 NOPS2 = NOPS2 +
750 $ ( NPROCS_REAL-2)*2*
751 $ ( 4.0D+0*(DBLE(NB)*DBLE(BW))*DBLE(NRHS) )
752 ENDIF
753*
754* Reduced system
755*
756 NOPS2 = NOPS2 +
757 $ NRHS*( NPROCS_REAL-1 ) * ( BW*BW )
758.GT. IF( NPROCS_REAL 1 ) THEN
759 NOPS2 = NOPS2 +
760 $ NRHS*( NPROCS_REAL-2 ) * ( 3 * BW*BW )
761 ENDIF
762*
763*
764* Multiply by 4 to get complex count
765*
766 NOPS2 = NOPS2 * DBLE(4)
767*
768* Calculate total megaflops - factorization and/or
769* solve -- for WALL and CPU time, and print output
770*
771* Print WALL time if machine supports it
772*
773.GT. IF( WTIME( 1 ) + WTIME( 2 ) 0.0D+0 ) THEN
774 TMFLOPS = NOPS /
775 $ ( ( WTIME( 1 )+WTIME( 2 ) ) * 1.0D+6 )
776 ELSE
777 TMFLOPS = 0.0D+0
778 END IF
779*
780.GT. IF( WTIME( 1 )+WTIME( 2 )0.0D+0 ) THEN
781 TMFLOPS2 = NOPS2 /
782 $ ( ( WTIME( 1 )+WTIME( 2 ) ) * 1.0D+6 )
783 ELSE
784 TMFLOPS2 = 0.0D+0
785 END IF
786*
787.GE. IF( WTIME( 2 )0.0D+0 )
788 $ WRITE( NOUT, FMT = 9993 ) 'wall', UPLO,
789 $ N,
790 $ BW,
791 $ NB, NRHS, NPROW, NPCOL,
792 $ WTIME( 1 ), WTIME( 2 ), TMFLOPS,
793 $ TMFLOPS2, PASSED
794*
795* Print CPU time if machine supports it
796*
797.GT. IF( CTIME( 1 )+CTIME( 2 )0.0D+0 ) THEN
798 TMFLOPS = NOPS /
799 $ ( ( CTIME( 1 )+CTIME( 2 ) ) * 1.0D+6 )
800 ELSE
801 TMFLOPS = 0.0D+0
802 END IF
803*
804.GT. IF( CTIME( 1 )+CTIME( 2 )0.0D+0 ) THEN
805 TMFLOPS2 = NOPS2 /
806 $ ( ( CTIME( 1 )+CTIME( 2 ) ) * 1.0D+6 )
807 ELSE
808 TMFLOPS2 = 0.0D+0
809 END IF
810*
811.GE. IF( CTIME( 2 )0.0D+0 )
812 $ WRITE( NOUT, FMT = 9993 ) 'cpu ', UPLO,
813 $ N,
814 $ BW,
815 $ NB, NRHS, NPROW, NPCOL,
816 $ CTIME( 1 ), CTIME( 2 ), TMFLOPS,
817 $ TMFLOPS2, PASSED
818*
819 END IF
820 20 CONTINUE
821*
822*
823 30 CONTINUE
824* NNB loop
825*
826 45 CONTINUE
827* BW[] loop
828*
829 40 CONTINUE
830* NMAT loop
831*
832 CALL BLACS_GRIDEXIT( ICTXT )
833 CALL BLACS_GRIDEXIT( ICTXTB )
834*
835 50 CONTINUE
836* NGRIDS DROPOUT
837 60 CONTINUE
838* NGRIDS loop
839*
840* Print ending messages and close output file
841*
842.EQ. IF( IAM0 ) THEN
843 KTESTS = KPASS + KFAIL + KSKIP
844 WRITE( NOUT, FMT = * )
845 WRITE( NOUT, FMT = 9992 ) KTESTS
846 IF( CHECK ) THEN
847 WRITE( NOUT, FMT = 9991 ) KPASS
848 WRITE( NOUT, FMT = 9989 ) KFAIL
849 ELSE
850 WRITE( NOUT, FMT = 9990 ) KPASS
851 END IF
852 WRITE( NOUT, FMT = 9988 ) KSKIP
853 WRITE( NOUT, FMT = * )
854 WRITE( NOUT, FMT = * )
855 WRITE( NOUT, FMT = 9987 )
856.NE..AND..NE. IF( NOUT6 NOUT0 )
857 $ CLOSE ( NOUT )
858 END IF
859*
860 CALL BLACS_EXIT( 0 )
861*
862 9999 FORMAT( 'illegal ', A6, ': ', A5, ' = ', I3,
863 $ '; it should be at least 1' )
864 9998 FORMAT( 'illegal grid: nprow*npcol = ', I4, '. it can be at most',
865 $ I4 )
866 9997 FORMAT( 'bad ', A6, ' parameters: going on to next test case.' )
867 9996 FORMAT( 'unable to perform ', A, ': need totmem of at least',
868 $ I11 )
869 9995 FORMAT( 'time ul n bw nb nrhs p q l*u time ',
870 $ 'slv time mflops mflop2 check' )
871 9994 FORMAT( '---- -- ------ --- ---- ----- -- ---- -------- ',
872 $ '-------- ------ ------ ------' )
873 9993 FORMAT( A4, 2X, A1, 1X, I6, 1X, I3, 1X, I4, 1X,
874 $ I5, 1X, I2, 1X,
875 $ I4, 1X, F8.3, F9.4, F9.2, F9.2, 1X, A6 )
876 9992 FORMAT( 'finished ', I6, ' tests, with the following results:' )
877 9991 FORMAT( I5, ' tests completed and passed residual checks.' )
878 9990 FORMAT( I5, ' tests completed without checking.' )
879 9989 FORMAT( I5, ' tests completed and failed residual checks.' )
880 9988 FORMAT( I5, ' tests skipped because of illegal input values.' )
881 9987 FORMAT( 'END OF TESTS.' )
882 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 )
883 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 )
884*
885 STOP
886*
887* End of PZPBTRS_DRIVER
888*
889 END
890*
pzmatgen
subroutine pzmatgen(ictxt, aform, diag, m, n, mb, nb, a, lda, iarow, iacol, iseed, iroff, irnum, icoff, icnum, myrow, mycol, nprow, npcol)
Definition pzmatgen.f:4
the
end diagonal values have been computed in the(sparse) matrix id.SOL
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
blacs_gridinit
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
Definition mpi.f:745
pzlange
double precision function pzlange(norm, m, n, a, ia, ja, desca, work)
Definition mpi.f:1287
descinit
subroutine descinit(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld, info)
Definition mpi.f:777
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition mpi.f:786
pzbmatgen
subroutine pzbmatgen(ictxt, aform, aform2, bwl, bwu, n, mb, nb, a, lda, iarow, iacol, iseed, myrow, mycol, nprow, npcol)
Definition pzbmatgen.f:5
pzchekpad
subroutine pzchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
Definition pzchekpad.f:3
pzfillpad
subroutine pzfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition pzfillpad.f:2
pzpbdriver
program pzpbdriver
Definition pzpbdriver.f:1
pzpbinfo
subroutine pzpbinfo(summry, nout, uplo, nmat, nval, ldnval, nbw, bwval, ldbwval, nnb, nbval, ldnbval, nnr, nrval, ldnrval, nnbr, nbrval, ldnbrval, ngrids, pval, ldpval, qval, ldqval, thresh, work, iam, nprocs)
Definition pzpbinfo.f:6
pzpblaschk
subroutine pzpblaschk(symm, uplo, n, bwl, bwu, nrhs, x, ix, jx, descx, iaseed, a, ia, ja, desca, ibseed, anorm, resid, work, worksiz)
Definition pzpblaschk.f:4
pzpbtrf
subroutine pzpbtrf(uplo, n, bw, a, ja, desca, af, laf, work, lwork, info)
Definition pzpbtrf.f:3
pzpbtrs
subroutine pzpbtrs(uplo, n, bw, nrhs, a, ja, desca, b, ib, descb, af, laf, work, lwork, info)
Definition pzpbtrs.f:3
slboot
subroutine slboot()
Definition sltimer.f:2
sltimer
subroutine sltimer(i)
Definition sltimer.f:47
slcombine
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)
Definition sltimer.f:267