SCALAPACK 2.2.2
LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches
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*
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
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
pzbmatgen
subroutine pzbmatgen(ictxt, aform, aform2, bwl, bwu, n, mb, nb, a, lda, iarow, iacol, iseed, myrow, mycol, nprow, npcol)
Definition pzbmatgen.f:5
pzchekpad
subroutine pzchekpad(ictxt, mess, m, n, a, lda, ipre, ipost, chkval)
Definition pzchekpad.f:3
pzfillpad
subroutine pzfillpad(ictxt, m, n, a, lda, ipre, ipost, chkval)
Definition pzfillpad.f:2
pzlange
double precision function pzlange(norm, m, n, a, ia, ja, desca, work)
Definition pzlange.f:3
pzpbdriver
program pzpbdriver
Definition pzpbdriver.f:1
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
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
pzpbtrf
subroutine pzpbtrf(uplo, n, bw, a, ja, desca, af, laf, work, lwork, info)
Definition pzpbtrf.f:3
pzpbtrs
subroutine pzpbtrs(uplo, n, bw, nrhs, a, ja, desca, b, ib, descb, af, laf, work, lwork, info)
Definition pzpbtrs.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