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