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