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