ScaLAPACK 2.1  2.1
ScaLAPACK: Scalable Linear Algebra PACKage
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 *
max
#define max(A, B)
Definition: pcgemr.c:180
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
pcbmatgen
subroutine pcbmatgen(ICTXT, AFORM, AFORM2, BWL, BWU, N, MB, NB, A, LDA, IAROW, IACOL, ISEED, MYROW, MYCOL, NPROW, NPCOL)
Definition: pcbmatgen.f:5
sltimer
subroutine sltimer(I)
Definition: sltimer.f:47
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
lsame
logical function lsame(CA, CB)
Definition: tools.f:1724
pcpbtrf
subroutine pcpbtrf(UPLO, N, BW, A, JA, DESCA, AF, LAF, WORK, LWORK, INFO)
Definition: pcpbtrf.f:3
pcchekpad
subroutine pcchekpad(ICTXT, MESS, M, N, A, LDA, IPRE, IPOST, CHKVAL)
Definition: pcchekpad.f:3
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
slboot
subroutine slboot()
Definition: sltimer.f:2
pcpbtrs
subroutine pcpbtrs(UPLO, N, BW, NRHS, A, JA, DESCA, B, IB, DESCB, AF, LAF, WORK, LWORK, INFO)
Definition: pcpbtrs.f:3
pclange
real function pclange(NORM, M, N, A, IA, JA, DESCA, WORK)
Definition: pclange.f:3
pcfillpad
subroutine pcfillpad(ICTXT, M, N, A, LDA, IPRE, IPOST, CHKVAL)
Definition: pcfillpad.f:2
numroc
integer function numroc(N, NB, IPROC, ISRCPROC, NPROCS)
Definition: numroc.f:2
slcombine
subroutine slcombine(ICTXT, SCOPE, OP, TIMETYPE, N, IBEG, TIMES)
Definition: sltimer.f:267
min
#define min(A, B)
Definition: pcgemr.c:181