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,
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*
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
subroutine descinit(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld, info)
Definition descinit.f:3
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition numroc.f:2
subroutine pcbmatgen(ictxt, aform, aform2, bwl, bwu, n, mb, nb, a, lda, iarow, iacol, iseed, myrow, mycol, nprow, npcol)
Definition pcbmatgen.f:5
subroutine pcchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
Definition pcchekpad.f:3
subroutine pcfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition pcfillpad.f:2
#define max(A, B)
Definition pcgemr.c:180
#define min(A, B)
Definition pcgemr.c:181
real function pclange(norm, m, n, a, ia, ja, desca, work)
Definition pclange.f:3
program pcpbdriver
Definition pcpbdriver.f:1
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
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
subroutine pcpbtrf(uplo, n, bw, a, ja, desca, af, laf, work, lwork, info)
Definition pcpbtrf.f:3
subroutine pcpbtrs(uplo, n, bw, nrhs, a, ja, desca, b, ib, descb, af, laf, work, lwork, info)
Definition pcpbtrs.f:3
subroutine slboot()
Definition sltimer.f:2
subroutine sltimer(i)
Definition sltimer.f:47
subroutine slcombine(ictxt, scope, op, timetype, n, ibeg, times)
Definition sltimer.f:267
logical function lsame(ca, cb)
Definition tools.f:1724