OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pzptdriver.f
Go to the documentation of this file.
1 PROGRAM pzptdriver
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* PZPTDRIVER is a test program for the
13* ScaLAPACK Band Cholesky routines corresponding to the options
14* indicated by ZPT. 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, int_temp, ipa, ipb, ipostpad,
100 $ iprepad, IPW, ipw_size, ipw_solve,
101 $ ipw_solve_size, ip_driver_w, ip_fillin, j, k,
102 $ kfail, kpass, kskip, ktests, mycol, myrhs_size,
103 $ myrow, N, nb, nbw, ngrids, nmat, nnb, NNBR,
104 $ nnr, nout, np, npcol, nprocs, nprocs_real,
105 $ nprow, nq, nrhs, 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, pzptinfo,
124 $ pzptlaschk, pzpttrf, pzpttrs, 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 pzptinfo( 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 = 1
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)*int_one-1)/npcol + 1 )
276 $ + int_one
277 nb = max( nb, 2*int_one )
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*int_one, 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( (2), (2),
301 $ myrow, 0, nprow )
302 nq = numroc( n, nb, mycol, 0, npcol )
303*
304 IF( check ) THEN
305 iprepad = ((2)+10)
306 imidpad = 10
307 ipostpad = ((2)+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, n, (2),
317 $ nb, 1, 0, 0,
318 $ ictxtb, nb+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 ) = ((2)+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 + (nb+10)*(2)
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 $ (12*npcol + 3*nb)
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 = 8*npcol
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 )*zplxsz
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( ((2)+10), nb )
413*
414 IF( check ) THEN
415*
416* Calculate the amount of workspace required by
417* the checking routines.
418*
419* PZLANGE
420 worksiz = max( worksiz, desca2d( nb_ ) )
421*
422* PZPTLASCHK
423 worksiz = max( worksiz,
424 $ max(5,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 )*zplxsz
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 pzbmatgen( ictxt, uplo, 't', BW, BW, N, (2), NB,
455 $ MEM( IPA ), NB+10, 0, 0, IASEED, MYROW,
456 $ MYCOL, NPROW, NPCOL )
457 CALL PZFILLPAD( ICTXT, NQ, NP, MEM( IPA-IPREPAD ),
458 $ NB+10, IPREPAD, IPOSTPAD,
459 $ PADVAL )
460*
461 CALL PZFILLPAD( ICTXT, WORKSIZ, 1,
462 $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ,
463 $ IPREPAD, IPOSTPAD, PADVAL )
464*
465* Calculate norm of A for residual error-checking
466*
467 IF( CHECK ) THEN
468*
469 ANORM = PZLANGE( 'i', N,
470 $ (2), MEM( IPA ), 1, 1,
471 $ DESCA2D, MEM( IP_DRIVER_W ) )
472 CALL PZCHEKPAD( ICTXT, 'pzlange', NQ, NP,
473 $ MEM( IPA-IPREPAD ), NB+10,
474 $ IPREPAD, IPOSTPAD, PADVAL )
475 CALL PZCHEKPAD( ICTXT, 'pzlange',
476 $ WORKSIZ, 1,
477 $ MEM( IP_DRIVER_W-IPREPAD ), WORKSIZ,
478 $ IPREPAD, IPOSTPAD, PADVAL )
479 END IF
480*
481 IF( LSAME( UPLO, 'l' ) ) THEN
482 INT_TEMP = 0
483 ELSE
484 INT_TEMP = DESCA2D( LLD_ )
485 ENDIF
486*
487* For SPD Tridiagonal complex matrices, diagonal is stored
488* as a real. Thus, compact D into half the space
489*
490 DO 10 H=1, NUMROC(N,NB,MYCOL,0,NPCOL)/2
491 MEM( IPA+INT_TEMP+H-1 ) = MEM( IPA+INT_TEMP+2*H-2 )
492 $ +MEM( IPA+INT_TEMP+2*H-1 )*( 0.0D+0, 1.0D+0 )
493 10 CONTINUE
494.NE. IF( 2*(NUMROC(N,NB,MYCOL,0,NPCOL)/2)
495 $ NUMROC(N,NB,MYCOL,0,NPCOL) ) THEN
496 H=NUMROC(N,NB,MYCOL,0,NPCOL)/2+1
497 MEM( IPA+INT_TEMP+H-1 ) = MEM( IPA+INT_TEMP+2*H-2 )
498 ENDIF
499*
500*
501 CALL SLBOOT()
502 CALL BLACS_BARRIER( ICTXT, 'all' )
503*
504* Perform factorization
505*
506 CALL SLTIMER( 1 )
507*
508 CALL PZPTTRF( N, MEM( IPA+INT_TEMP ),
509 $ MEM( IPA+1*( NB+10-INT_TEMP ) ), 1, DESCA,
510 $ MEM( IP_FILLIN ), FILLIN_SIZE, MEM( IPW ),
511 $ IPW_SIZE, INFO )
512*
513 CALL SLTIMER( 1 )
514*
515.NE. IF( INFO0 ) THEN
516.EQ. IF( IAM0 ) THEN
517 WRITE( NOUT, FMT = * ) 'pzpttrf info=', INFO
518 ENDIF
519 KFAIL = KFAIL + 1
520 GO TO 30
521 END IF
522*
523 IF( CHECK ) THEN
524*
525* Check for memory overwrite in factorization
526*
527 CALL PZCHEKPAD( ICTXT, 'pzpttrf', NQ,
528 $ NP, MEM( IPA-IPREPAD ), NB+10,
529 $ IPREPAD, IPOSTPAD, PADVAL )
530 END IF
531*
532*
533* Loop over the different values for NRHS
534*
535 DO 20 HH = 1, NNR
536*
537 IERR( 1 ) = 0
538*
539 NRHS = NRVAL( HH )
540*
541* Initialize Array Descriptor for rhs
542*
543 CALL DESCINIT( DESCB2D, N, NRHS, NB, 1, 0, 0,
544 $ ICTXTB, NB+10, IERR( 1 ) )
545*
546* Convert this to 1D descriptor
547*
548 DESCB( 1 ) = 502
549 DESCB( 3 ) = N
550 DESCB( 4 ) = NB
551 DESCB( 5 ) = 0
552 DESCB( 2 ) = ICTXT
553 DESCB( 6 ) = DESCB2D( LLD_ )
554 DESCB( 7 ) = 0
555*
556* reset free_ptr to reuse space for right hand sides
557*
558.GT. IF( IPB 0 ) THEN
559 FREE_PTR = IPB
560 ENDIF
561*
562 FREE_PTR = FREE_PTR + IPREPAD
563 IPB = FREE_PTR
564 FREE_PTR = FREE_PTR + NRHS*DESCB2D( LLD_ )
565 $ + IPOSTPAD
566*
567* Allocate workspace for workspace in TRS routine:
568*
569 IPW_SOLVE_SIZE = (10+2*MIN(100,NRHS))*NPCOL+4*NRHS
570*
571 IPW_SOLVE = FREE_PTR
572 FREE_PTR = FREE_PTR + IPW_SOLVE_SIZE
573*
574 IERR( 1 ) = 0
575.GT. IF( FREE_PTRMEMSIZ ) THEN
576.EQ. IF( IAM0 )
577 $ WRITE( NOUT, FMT = 9996 )'solve',
578 $ ( FREE_PTR )*ZPLXSZ
579 IERR( 1 ) = 1
580 END IF
581*
582* Check all processes for an error
583*
584 CALL IGSUM2D( ICTXT, 'all', ' ', 1, 1,
585 $ IERR, 1, -1, 0 )
586*
587.GT. IF( IERR( 1 )0 ) THEN
588.EQ. IF( IAM0 )
589 $ WRITE( NOUT, FMT = 9997 ) 'memory'
590 KSKIP = KSKIP + 1
591 GO TO 15
592 END IF
593*
594 MYRHS_SIZE = NUMROC( N, NB, MYCOL, 0, NPCOL )
595*
596* Generate RHS
597*
598 CALL PZMATGEN(ICTXTB, 'no', 'no',
599 $ DESCB2D( M_ ), DESCB2D( N_ ),
600 $ DESCB2D( MB_ ), DESCB2D( NB_ ),
601 $ MEM( IPB ),
602 $ DESCB2D( LLD_ ), DESCB2D( RSRC_ ),
603 $ DESCB2D( CSRC_ ),
604 $ IBSEED, 0, MYRHS_SIZE, 0, NRHS, MYCOL,
605 $ MYROW, NPCOL, NPROW )
606*
607 IF( CHECK ) THEN
608 CALL PZFILLPAD( ICTXTB, NB, NRHS,
609 $ MEM( IPB-IPREPAD ),
610 $ DESCB2D( LLD_ ),
611 $ IPREPAD, IPOSTPAD,
612 $ PADVAL )
613 CALL PZFILLPAD( ICTXT, WORKSIZ, 1,
614 $ MEM( IP_DRIVER_W-IPREPAD ),
615 $ WORKSIZ, IPREPAD,
616 $ IPOSTPAD, PADVAL )
617 END IF
618*
619*
620 CALL BLACS_BARRIER( ICTXT, 'all')
621 CALL SLTIMER( 2 )
622*
623* Solve linear system via factorization
624*
625 CALL PZPTTRS( UPLO, N, NRHS, MEM( IPA+INT_TEMP ),
626 $ MEM( IPA+1*( NB+10-INT_TEMP ) ), 1,
627 $ DESCA, MEM( IPB ), 1, DESCB,
628 $ MEM( IP_FILLIN ), FILLIN_SIZE,
629 $ MEM( IPW_SOLVE ), IPW_SOLVE_SIZE,
630 $ INFO )
631*
632 CALL SLTIMER( 2 )
633*
634.NE. IF( INFO0 ) THEN
635.EQ. IF( IAM0 )
636 $ WRITE( NOUT, FMT = * ) 'pzpttrs info=', INFO
637 KFAIL = KFAIL + 1
638 PASSED = 'failed'
639 GO TO 20
640 END IF
641*
642 IF( CHECK ) THEN
643*
644* check for memory overwrite
645*
646 CALL PZCHEKPAD( ICTXT, 'pzpttrs-work',
647 $ WORKSIZ, 1,
648 $ MEM( IP_DRIVER_W-IPREPAD ),
649 $ WORKSIZ, IPREPAD,
650 $ IPOSTPAD, PADVAL )
651*
652* check the solution to rhs
653*
654 SRESID = ZERO
655*
656* Reset descriptor describing A to 1-by-P grid for
657* use in banded utility routines
658*
659 CALL DESCINIT( DESCA2D, (2), N,
660 $ (2), NB, 0, 0,
661 $ ICTXT, (2), IERR( 1 ) )
662 CALL PZPTLASCHK( 'h', UPLO, N, BW, BW, NRHS,
663 $ MEM( IPB ), 1, 1, DESCB2D,
664 $ IASEED, MEM( IPA ), 1, 1, DESCA2D,
665 $ IBSEED, ANORM, SRESID,
666 $ MEM( IP_DRIVER_W ), WORKSIZ )
667*
668.EQ. IF( IAM0 ) THEN
669.GT. IF( SRESIDTHRESH )
670 $ WRITE( NOUT, FMT = 9985 ) SRESID
671 END IF
672*
673* The second test is a NaN trap
674*
675.LE..AND. IF( ( SRESIDTHRESH )
676.EQ. $ ( (SRESID-SRESID)0.0D+0 ) ) THEN
677 KPASS = KPASS + 1
678 PASSED = 'passed'
679 ELSE
680 KFAIL = KFAIL + 1
681 PASSED = 'failed'
682 END IF
683*
684 END IF
685*
686 15 CONTINUE
687* Skipped tests jump to here to print out "SKIPPED"
688*
689* Gather maximum of all CPU and WALL clock timings
690*
691 CALL SLCOMBINE( ICTXT, 'all', '>', 'w', 2, 1,
692 $ WTIME )
693 CALL SLCOMBINE( ICTXT, 'all', '>', 'c', 2, 1,
694 $ CTIME )
695*
696* Print results
697*
698.EQ..AND..EQ. IF( MYROW0 MYCOL0 ) THEN
699*
700 NOPS = 0
701 NOPS2 = 0
702*
703 N_FIRST = NB
704 NPROCS_REAL = ( N-1 )/NB + 1
705 N_LAST = MOD( N-1, NB ) + 1
706*
707*
708 NOPS = NOPS + DBLE(BW)*( -2.D0 / 3.D0+DBLE(BW)*
709 $ ( -1.D0+DBLE(BW)*( -1.D0 / 3.D0 ) ) ) +
710 $ DBLE(N)*( 1.D0+DBLE(BW)*( 3.D0 /
711 $ 2.D0+DBLE(BW)*( 1.D0 / 2.D0 ) ) )
712 NOPS = NOPS + DBLE(BW)*( -1.D0 / 6.D0+DBLE(BW)
713 $ *( -1.D0 /2.D0+DBLE(BW)
714 $ *( -1.D0 / 3.D0 ) ) ) +
715 $ DBLE(N)*( DBLE(BW) /
716 $ 2.D0*( 1.D0+DBLE(BW) ) )
717*
718 NOPS = NOPS +
719 $ DBLE(NRHS)*( ( 2*DBLE(N)-DBLE(BW) )*
720 $ ( DBLE(BW)+1.D0 ) )+ DBLE(NRHS)*
721 $ ( DBLE(BW)*( 2*DBLE(N)-
722 $ ( DBLE(BW)+1.D0 ) ) )
723*
724*
725* Second calc to represent actual hardware speed
726*
727* NB bw^2 flops for LLt factorization in 1st proc
728*
729 NOPS2 = ( (DBLE(N_FIRST))* DBLE(BW)**2 )
730*
731.GT. IF ( NPROCS_REAL 1) THEN
732* 4 NB bw^2 flops for LLt factorization and
733* spike calc in last processor
734*
735 NOPS2 = NOPS2 +
736 $ 4*( (DBLE(N_LAST)*DBLE(BW)**2) )
737 ENDIF
738*
739.GT. IF ( NPROCS_REAL 2) THEN
740* 4 NB bw^2 flops for LLt factorization and
741* spike calc in other processors
742*
743 NOPS2 = NOPS2 + (NPROCS_REAL-2)*
744 $ 4*( (DBLE(NB)*DBLE(BW)**2) )
745 ENDIF
746*
747* Reduced system
748*
749 NOPS2 = NOPS2 +
750 $ ( NPROCS_REAL-1 ) * ( BW*BW*BW/3 )
751.GT. IF( NPROCS_REAL 1 ) THEN
752 NOPS2 = NOPS2 +
753 $ ( NPROCS_REAL-2 ) * ( 2 * BW*BW*BW )
754 ENDIF
755*
756*
757* nrhs * 4 n_first*bw flops for LLt solve in proc 1.
758*
759 NOPS2 = NOPS2 +
760 $ ( 4.0D+0*(DBLE(N_FIRST)*DBLE(BW))*DBLE(NRHS) )
761*
762.GT. IF ( NPROCS_REAL 1 ) THEN
763*
764* 2*nrhs*4 n_last*bw flops for LLt solve in last.
765*
766 NOPS2 = NOPS2 +
767 $ 2*( 4.0D+0*(DBLE(N_LAST)*DBLE(BW))*DBLE(NRHS) )
768 ENDIF
769*
770.GT. IF ( NPROCS_REAL 2 ) THEN
771*
772* 2 * nrhs * 4 NB*bw flops for LLt solve in others.
773*
774 NOPS2 = NOPS2 +
775 $ ( NPROCS_REAL-2)*2*
776 $ ( 4.0D+0*(DBLE(NB)*DBLE(BW))*DBLE(NRHS) )
777 ENDIF
778*
779* Reduced system
780*
781 NOPS2 = NOPS2 +
782 $ NRHS*( NPROCS_REAL-1 ) * ( BW*BW )
783.GT. IF( NPROCS_REAL 1 ) THEN
784 NOPS2 = NOPS2 +
785 $ NRHS*( NPROCS_REAL-2 ) * ( 3 * BW*BW )
786 ENDIF
787*
788*
789* Multiply by 4 to get complex count
790*
791 NOPS2 = NOPS2 * DBLE(4)
792*
793* Calculate total megaflops - factorization and/or
794* solve -- for WALL and CPU time, and print output
795*
796* Print WALL time if machine supports it
797*
798.GT. IF( WTIME( 1 ) + WTIME( 2 ) 0.0D+0 ) THEN
799 TMFLOPS = NOPS /
800 $ ( ( WTIME( 1 )+WTIME( 2 ) ) * 1.0D+6 )
801 ELSE
802 TMFLOPS = 0.0D+0
803 END IF
804*
805.GT. IF( WTIME( 1 )+WTIME( 2 )0.0D+0 ) THEN
806 TMFLOPS2 = NOPS2 /
807 $ ( ( WTIME( 1 )+WTIME( 2 ) ) * 1.0D+6 )
808 ELSE
809 TMFLOPS2 = 0.0D+0
810 END IF
811*
812.GE. IF( WTIME( 2 )0.0D+0 )
813 $ WRITE( NOUT, FMT = 9993 ) 'wall', UPLO,
814 $ N,
815 $ BW,
816 $ NB, NRHS, NPROW, NPCOL,
817 $ WTIME( 1 ), WTIME( 2 ), TMFLOPS,
818 $ TMFLOPS2, PASSED
819*
820* Print CPU time if machine supports it
821*
822.GT. IF( CTIME( 1 )+CTIME( 2 )0.0D+0 ) THEN
823 TMFLOPS = NOPS /
824 $ ( ( CTIME( 1 )+CTIME( 2 ) ) * 1.0D+6 )
825 ELSE
826 TMFLOPS = 0.0D+0
827 END IF
828*
829.GT. IF( CTIME( 1 )+CTIME( 2 )0.0D+0 ) THEN
830 TMFLOPS2 = NOPS2 /
831 $ ( ( CTIME( 1 )+CTIME( 2 ) ) * 1.0D+6 )
832 ELSE
833 TMFLOPS2 = 0.0D+0
834 END IF
835*
836.GE. IF( CTIME( 2 )0.0D+0 )
837 $ WRITE( NOUT, FMT = 9993 ) 'cpu ', UPLO,
838 $ N,
839 $ BW,
840 $ NB, NRHS, NPROW, NPCOL,
841 $ CTIME( 1 ), CTIME( 2 ), TMFLOPS,
842 $ TMFLOPS2, PASSED
843*
844 END IF
845 20 CONTINUE
846*
847*
848 30 CONTINUE
849* NNB loop
850*
851 45 CONTINUE
852* BW[] loop
853*
854 40 CONTINUE
855* NMAT loop
856*
857 CALL BLACS_GRIDEXIT( ICTXT )
858 CALL BLACS_GRIDEXIT( ICTXTB )
859*
860 50 CONTINUE
861* NGRIDS DROPOUT
862 60 CONTINUE
863* NGRIDS loop
864*
865* Print ending messages and close output file
866*
867.EQ. IF( IAM0 ) THEN
868 KTESTS = KPASS + KFAIL + KSKIP
869 WRITE( NOUT, FMT = * )
870 WRITE( NOUT, FMT = 9992 ) KTESTS
871 IF( CHECK ) THEN
872 WRITE( NOUT, FMT = 9991 ) KPASS
873 WRITE( NOUT, FMT = 9989 ) KFAIL
874 ELSE
875 WRITE( NOUT, FMT = 9990 ) KPASS
876 END IF
877 WRITE( NOUT, FMT = 9988 ) KSKIP
878 WRITE( NOUT, FMT = * )
879 WRITE( NOUT, FMT = * )
880 WRITE( NOUT, FMT = 9987 )
881.NE..AND..NE. IF( NOUT6 NOUT0 )
882 $ CLOSE ( NOUT )
883 END IF
884*
885 CALL BLACS_EXIT( 0 )
886*
887 9999 FORMAT( 'illegal ', A6, ': ', A5, ' = ', I3,
888 $ '; it should be at least 1' )
889 9998 FORMAT( 'illegal grid: nprow*npcol = ', I4, '. it can be at most',
890 $ I4 )
891 9997 FORMAT( 'bad ', A6, ' parameters: going on to next test case.' )
892 9996 FORMAT( 'unable to perform ', A, ': need totmem of at least',
893 $ I11 )
894 9995 FORMAT( 'time ul n bw nb nrhs p q l*u time ',
895 $ 'slv time mflops mflop2 check' )
896 9994 FORMAT( '---- -- ------ --- ---- ----- -- ---- -------- ',
897 $ '-------- ------ ------ ------' )
898 9993 FORMAT( A4, 2X, A1, 1X, I6, 1X, I3, 1X, I4, 1X,
899 $ I5, 1X, I2, 1X,
900 $ I4, 1X, F8.3, F9.4, F9.2, F9.2, 1X, A6 )
901 9992 FORMAT( 'finished ', I6, ' tests, with the following results:' )
902 9991 FORMAT( I5, ' tests completed and passed residual checks.' )
903 9990 FORMAT( I5, ' tests completed without checking.' )
904 9989 FORMAT( I5, ' tests completed and failed residual checks.' )
905 9988 FORMAT( I5, ' tests skipped because of illegal input values.' )
906 9987 FORMAT( 'END OF TESTS.' )
907 9986 FORMAT( '||A - ', A4, '|| / (||A|| * N * eps) = ', G25.7 )
908 9985 FORMAT( '||Ax-b||/(||x||*||A||*eps*N) ', F25.7 )
909*
910 STOP
911*
912* End of PZPTTRS_DRIVER
913*
914 END
915*
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
the
end diagonal values have been computed in the(sparse) matrix id.SOL
lsame
logical function lsame(ca, cb)
LSAME
Definition lsame.f:53
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
blacs_gridinit
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
Definition mpi.f:745
pzlange
double precision function pzlange(norm, m, n, a, ia, ja, desca, work)
Definition mpi.f:1287
descinit
subroutine descinit(desc, m, n, mb, nb, irsrc, icsrc, ictxt, lld, info)
Definition mpi.f:777
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
blacs_gridinfo
subroutine blacs_gridinfo(cntxt, nprow, npcol, myrow, mycol)
Definition mpi.f:754
numroc
integer function numroc(n, nb, iproc, isrcproc, nprocs)
Definition mpi.f:786
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
pzptdriver
program pzptdriver
Definition pzptdriver.f:1
pzptinfo
subroutine pzptinfo(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 pzptinfo.f:6
pzptlaschk
subroutine pzptlaschk(symm, uplo, n, bwl, bwu, nrhs, x, ix, jx, descx, iaseed, a, ia, ja, desca, ibseed, anorm, resid, work, worksiz)
Definition pzptlaschk.f:4
pzpttrf
subroutine pzpttrf(n, d, e, ja, desca, af, laf, work, lwork, info)
Definition pzpttrf.f:3
pzpttrs
subroutine pzpttrs(uplo, n, nrhs, d, e, ja, desca, b, ib, descb, af, laf, work, lwork, info)
Definition pzpttrs.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