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