OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
pzptinfo.f
Go to the documentation of this file.
1 SUBROUTINE pzptinfo( SUMMRY, NOUT, UPLO, NMAT, NVAL, LDNVAL, NBW,
2 $ BWVAL, LDBWVAL, NNB, NBVAL, LDNBVAL, NNR,
3 $ NRVAL, LDNRVAL, NNBR, NBRVAL, LDNBRVAL,
4 $ NGRIDS, PVAL, LDPVAL, QVAL, LDQVAL, THRESH,
5 $ WORK, IAM, NPROCS )
6*
7*
8*
9* -- ScaLAPACK routine (version 1.7) --
10* University of Tennessee, Knoxville, Oak Ridge National Laboratory,
11* and University of California, Berkeley.
12* November 15, 1997
13*
14* .. Scalar Arguments ..
15 CHARACTER UPLO
16 CHARACTER*(*) SUMMRY
17 INTEGER IAM,
18 $ LDBWVAL, LDNBRVAL, LDNBVAL, LDNRVAL, LDNVAL,
19 $ ldpval, ldqval, ngrids, nmat, nnb, nnbr, nbw,
20 $ nprocs, nnr, nout
21 REAL THRESH
22* ..
23* .. Array Arguments ..
24 INTEGER NBRVAL( LDNBRVAL ), NBVAL( LDNBVAL ),
25 $ nrval( ldnrval ), nval( ldnval ),
26 $ bwval( ldbwval),
27 $ pval( ldpval ), qval(ldqval), work( * )
28* ..
29*
30* Purpose
31* =======
32*
33* PZPTINFO get needed startup information for band factorization
34* and transmits it to all processes.
35*
36* Arguments
37* =========
38*
39* SUMMRY (global output) CHARACTER*(*)
40* Name of output (summary) file (if any). Only defined for
41* process 0.
42*
43* NOUT (global output) INTEGER
44* The unit number for output file. NOUT = 6, ouput to screen,
45* NOUT = 0, output to stderr. Only defined for process 0.
46*
47* UPLO (global output) CHARACTER
48* Specifies whether the upper or lower triangular part of the
49* symmetric matrix A is stored.
50* = 'U': Upper triangular
51* = 'L': Lower triangular
52*
53*
54* NMAT (global output) INTEGER
55* The number of different values that can be used for N.
56*
57* NVAL (global output) INTEGER array, dimension (LDNVAL)
58* The values of N (number of columns in matrix) to run the
59* code with.
60*
61* NBW (global output) INTEGER
62* The number of different values that can be used for @bw@.
63* BWVAL (global output) INTEGER array, dimension (LDNVAL)
64* The values of BW (number of subdiagonals in matrix) to run
65* the code with.
66*
67* LDNVAL (global input) INTEGER
68* The maximum number of different values that can be used for
69* N, LDNVAL > = NMAT.
70*
71* NNB (global output) INTEGER
72* The number of different values that can be used for NB.
73*
74* NBVAL (global output) INTEGER array, dimension (LDNBVAL)
75* The values of NB (blocksize) to run the code with.
76*
77* LDNBVAL (global input) INTEGER
78* The maximum number of different values that can be used for
79* NB, LDNBVAL >= NNB.
80*
81* NNR (global output) INTEGER
82* The number of different values that can be used for NRHS.
83*
84* NRVAL (global output) INTEGER array, dimension(LDNRVAL)
85* The values of NRHS (# of Right Hand Sides) to run the code
86* with.
87*
88* LDNRVAL (global input) INTEGER
89* The maximum number of different values that can be used for
90* NRHS, LDNRVAL >= NNR.
91*
92* NNBR (global output) INTEGER
93* The number of different values that can be used for NBRHS.
94*
95* NBRVAL (global output) INTEGER array, dimension (LDNBRVAL)
96* The values of NBRHS (RHS blocksize) to run the code with.
97*
98* LDNBRVAL (global input) INTEGER
99* The maximum number of different values that can be used for
100* NBRHS, LDNBRVAL >= NBRVAL.
101*
102* NGRIDS (global output) INTEGER
103* The number of different values that can be used for P & Q.
104*
105* PVAL (global output) INTEGER array, dimension (LDPVAL)
106* Not used (will be returned as all 1s) since proc grid is 1D
107*
108* LDPVAL (global input) INTEGER
109* The maximum number of different values that can be used for
110* P, LDPVAL >= NGRIDS.
111*
112* QVAL (global output) INTEGER array, dimension (LDQVAL)
113* The values of Q (number of process columns) to run the code
114* with.
115*
116* LDQVAL (global input) INTEGER
117* The maximum number of different values that can be used for
118* Q, LDQVAL >= NGRIDS.
119*
120* THRESH (global output) REAL
121* Indicates what error checks shall be run and printed out:
122* = 0 : Perform no error checking
123* > 0 : report all residuals greater than THRESH, perform
124* factor check only if solve check fails
125*
126* WORK (local workspace) INTEGER array of dimension >=
127* MAX( 8, LDNVAL+2*LDNBVAL+LDNRVAL+LDNBRVAL+LDPVAL+LDQVAL
128* $ +3*LDNVAL)
129* Used to pack input arrays in order to send info in one
130* message.
131*
132* IAM (local input) INTEGER
133* My process number.
134*
135* NPROCS (global input) INTEGER
136* The total number of processes.
137*
138* ======================================================================
139*
140* Note: For packing the information we assumed that the length in bytes
141* ===== of an integer is equal to the length in bytes of a real single
142* precision.
143*
144* =====================================================================
145*
146* Code Developer: Andrew J. Cleary, University of Tennessee.
147* Current address: Lawrence Livermore National Labs.
148* This version released: August, 2001.
149*
150* ======================================================================
151*
152* .. Parameters ..
153 INTEGER NIN
154 PARAMETER ( NIN = 11 )
155* ..
156* .. Local Scalars ..
157 INTEGER I, ICTXT
158 CHARACTER*79 USRINFO
159 DOUBLE PRECISION EPS
160* ..
161* .. External Subroutines ..
162 EXTERNAL blacs_abort, blacs_get, blacs_gridexit,
163 $ blacs_gridinit, blacs_setup, icopy, igebr2d,
164 $ igebs2d, sgebr2d, sgebs2d
165* ..
166* .. External Functions ..
167 LOGICAL LSAME
168 DOUBLE PRECISION PDLAMCH
169 EXTERNAL LSAME, PDLAMCH
170* ..
171* .. Intrinsic Functions ..
172 INTRINSIC max, min
173* ..
174* .. Executable Statements ..
175*
176* Process 0 reads the input data, broadcasts to other processes and
177* writes needed information to NOUT
178*
179 IF( iam.EQ.0 ) THEN
180*
181* Open file and skip data file header
182*
183 OPEN( nin, file = 'BLLT.dat', status = 'OLD' )
184 READ( nin, fmt = * ) summry
185 summry = ' '
186*
187* Read in user-supplied info about machine type, compiler, etc.
188*
189 READ( nin, fmt = 9999 ) usrinfo
190*
191* Read name and unit number for summary output file
192*
193 READ( nin, fmt = * ) summry
194 READ( nin, fmt = * ) nout
195 IF( nout.NE.0 .AND. nout.NE.6 )
196 $ OPEN( nout, file = summry, status = 'UNKNOWN' )
197*
198* Read and check the parameter values for the tests.
199*
200* Get UPLO
201*
202 READ( nin, fmt = * ) uplo
203*
204*
205* Get number of matrices and their dimensions
206*
207 READ( nin, fmt = * ) nmat
208 IF( nmat.LT.1 .OR. nmat.GT.ldnval ) THEN
209 WRITE( nout, fmt = 9994 ) 'N', ldnval
210 GO TO 20
211 END IF
212 READ( nin, fmt = * ) ( nval( i ), i = 1, nmat )
213*
214* Get bandwidths
215*
216 READ( nin, fmt = * ) nbw
217 nbw = 1
218 IF( nbw.LT.1 .OR. nbw.GT.ldbwval ) THEN
219 WRITE( nout, fmt = 9994 ) 'BW', ldbwval
220 GO TO 20
221 END IF
222 READ( nin, fmt = * ) ( bwval( i ), i = 1, nbw )
223*
224* Get values of NB
225*
226 READ( nin, fmt = * ) nnb
227 IF( nnb.LT.1 .OR. nnb.GT.ldnbval ) THEN
228 WRITE( nout, fmt = 9994 ) 'NB', ldnbval
229 GO TO 20
230 END IF
231 READ( nin, fmt = * ) ( nbval( i ), i = 1, nnb )
232*
233* Get values of NRHS
234*
235 READ( nin, fmt = * ) nnr
236 IF( nnr.LT.1 .OR. nnr.GT.ldnrval ) THEN
237 WRITE( nout, fmt = 9994 ) 'NRHS', ldnrval
238 GO TO 20
239 END IF
240 READ( nin, fmt = * ) ( nrval( i ), i = 1, nnr )
241*
242* Get values of NBRHS
243*
244 READ( nin, fmt = * ) nnbr
245 IF( nnbr.LT.1 .OR. nnbr.GT.ldnbrval ) THEN
246 WRITE( nout, fmt = 9994 ) 'NBRHS', ldnbrval
247 GO TO 20
248 END IF
249 READ( nin, fmt = * ) ( nbrval( i ), i = 1, nnbr )
250*
251* Get number of grids
252*
253 READ( nin, fmt = * ) ngrids
254 IF( ngrids.LT.1 .OR. ngrids.GT.ldpval ) THEN
255 WRITE( nout, fmt = 9994 ) 'Grids', ldpval
256 GO TO 20
257 ELSE IF( ngrids.GT.ldqval ) THEN
258 WRITE( nout, fmt = 9994 ) 'Grids', ldqval
259 GO TO 20
260 END IF
261*
262* Processor grid must be 1D so set PVAL to 1
263 DO 8738 i = 1, ngrids
264 pval( i ) = 1
265 8738 CONTINUE
266*
267* Get values of Q
268*
269 READ( nin, fmt = * ) ( qval( i ), i = 1, ngrids )
270*
271* Get level of checking
272*
273 READ( nin, fmt = * ) thresh
274*
275* Close input file
276*
277 CLOSE( nin )
278*
279* For pvm only: if virtual machine not set up, allocate it and
280* spawn the correct number of processes.
281*
282 IF( nprocs.LT.1 ) THEN
283 nprocs = 0
284 DO 10 i = 1, ngrids
285 nprocs = max( nprocs, pval( i )*qval( i ) )
286 10 CONTINUE
287 CALL blacs_setup( iam, nprocs )
288 END IF
289*
290* Temporarily define blacs grid to include all processes so
291* information can be broadcast to all processes.
292*
293 CALL blacs_get( -1, 0, ictxt )
294 CALL blacs_gridinit( ictxt, 'Row-major', 1, nprocs )
295*
296* Compute machine epsilon
297*
298 eps = pdlamch( ictxt, 'eps' )
299*
300* Pack information arrays and broadcast
301*
302 CALL SGEBS2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1 )
303 I = 1
304 WORK( I ) = NMAT
305 I = I+1
306 WORK( I ) = NBW
307 I = I+1
308 WORK( I ) = NNB
309 I = I+1
310 WORK( I ) = NNR
311 I = I+1
312 WORK( I ) = NNBR
313 I = I+1
314 WORK( I ) = NGRIDS
315 I = I+1
316 IF( LSAME( UPLO, 'l' ) ) THEN
317 WORK( I ) = 1
318 ELSE
319 WORK( I ) = 2
320 END IF
321 I = I+1
322* Send number of elements to be sent
323 CALL IGEBS2D( ICTXT, 'all', ' ', 1, 1, I-1, 1 )
324* Send elements
325 CALL IGEBS2D( ICTXT, 'all', ' ', I-1, 1, WORK, I-1 )
326*
327 I = 1
328 CALL ICOPY( NMAT, NVAL, 1, WORK( I ), 1 )
329 I = I + NMAT
330 CALL ICOPY( NBW, BWVAL, 1, WORK( I ), 1 )
331 I = I + NBW
332 CALL ICOPY( NNB, NBVAL, 1, WORK( I ), 1 )
333 I = I + NNB
334 CALL ICOPY( NNR, NRVAL, 1, WORK( I ), 1 )
335 I = I + NNR
336 CALL ICOPY( NNBR, NBRVAL, 1, WORK( I ), 1 )
337 I = I + NNBR
338 CALL ICOPY( NGRIDS, PVAL, 1, WORK( I ), 1 )
339 I = I + NGRIDS
340 CALL ICOPY( NGRIDS, QVAL, 1, WORK( I ), 1 )
341 I = I + NGRIDS
342 CALL IGEBS2D( ICTXT, 'all', ' ', I-1, 1, WORK, I-1 )
343*
344* regurgitate input
345*
346 WRITE( NOUT, FMT = 9999 )
347 $ 'scalapack banded linear systems.'
348 WRITE( NOUT, FMT = 9999 ) USRINFO
349 WRITE( NOUT, FMT = * )
350 WRITE( NOUT, FMT = 9999 )
351 $ 'tests of the parallel '//
352 $ 'complex single precision band matrix solve '
353 WRITE( NOUT, FMT = 9999 )
354 $ 'The following scaled residual '//
355 $ 'checks will be computed:'
356 WRITE( NOUT, FMT = 9999 )
357 $ ' Solve residual = ||ax - b|| / '//
358 $ '(||x|| * ||a|| * eps * n)'
359 IF( LSAME( UPLO, 'l' ) ) THEN
360 WRITE( NOUT, FMT = 9999 )
361 $ ' factorization residual = ||a - ll''|| /'//
362 $ ' (||a|| * eps * n)'
363 ELSE
364 WRITE( NOUT, FMT = 9999 )
365 $ ' factorization residual = ||a - u''u|| /'//
366 $ ' (||a|| * eps * n)'
367 END IF
368 WRITE( NOUT, FMT = 9999 )
369 $ 'the matrix a is randomly '//
370 $ 'generated for each test.'
371 WRITE( NOUT, FMT = * )
372 WRITE( NOUT, FMT = 9999 )
373 $ 'an explanation of the input/output '//
374 $ 'parameters follows:'
375 WRITE( NOUT, FMT = 9999 )
376 $ 'time : indicates whether wall or '//
377 $ 'cpu time was used.'
378*
379 WRITE( NOUT, FMT = 9999 )
380 $ 'uplo : whether data represents ''upper'//
381 $ ''' or ''lower'' triangular portion of array a.'
382 WRITE( NOUT, FMT = 9999 )
383 $ 'trans : whether solve is to be done with'//
384 $ ' ''transpose'' of matrix a(t,c) or not(n).'
385 WRITE( NOUT, FMT = 9999 )
386 $ 'n : the number of rows and columns '//
387 $ 'in the matrix a.'
388 WRITE( NOUT, FMT = 9999 )
389 $ 'bw : the number of diagonals '//
390 $ 'in the matrix a.'
391 WRITE( NOUT, FMT = 9999 )
392 $ 'nb : the size of the column panels the'//
393 $ ' matrix a is split into. [-1 for default]'
394 WRITE( NOUT, FMT = 9999 )
395 $ 'nrhs : the total number of rhs to solve'//
396 $ ' for.'
397 WRITE( NOUT, FMT = 9999 )
398 $ 'nbrhs : the number of rhs to be put on '//
399 $ 'a column of processes before going'
400 WRITE( NOUT, FMT = 9999 )
401 $ ' on to the next column of processes.'
402 WRITE( NOUT, FMT = 9999 )
403 $ 'p : the number of process rows.'
404 WRITE( NOUT, FMT = 9999 )
405 $ 'q : the number of process columns.'
406 WRITE( NOUT, FMT = 9999 )
407 $ 'thresh : If a residual value is less than'//
408 $ ' thresh, check is flagged as passed'
409 WRITE( NOUT, FMT = 9999 )
410 $ 'fact time: time in seconds to factor the'//
411 $ ' matrix'
412 WRITE( NOUT, FMT = 9999 )
413 $ 'sol time: time in seconds to solve the'//
414 $ ' system.'
415 WRITE( NOUT, FMT = 9999 )
416 $ 'mflops : rate of execution for factor '//
417 $ 'and solve using sequential operation count.'
418 WRITE( NOUT, FMT = 9999 )
419 $ 'mflop2 : rough estimate of speed '//
420 $ 'using actual op count(accurate big p,n).'
421 WRITE( NOUT, FMT = * )
422 WRITE( NOUT, FMT = 9999 )
423 $ 'the following parameter values will be used:'
424 WRITE( NOUT, FMT = 9999 )
425 $ ' uplo : '//UPLO
426 WRITE( NOUT, FMT = 9996 )
427 $ 'n ', ( NVAL(I), I = 1, MIN(NMAT, 10) )
428.GT. IF( NMAT10 )
429 $ WRITE( NOUT, FMT = 9997 ) ( NVAL(I), I = 11, NMAT )
430 WRITE( NOUT, FMT = 9996 )
431 $ 'bw ', ( BWVAL(I), I = 1, MIN(NBW, 10) )
432.GT. IF( NBW10 )
433 $ WRITE( NOUT, FMT = 9997 ) ( BWVAL(I), I = 11, NBW )
434 WRITE( NOUT, FMT = 9996 )
435 $ 'nb ', ( NBVAL(I), I = 1, MIN(NNB, 10) )
436.GT. IF( NNB10 )
437 $ WRITE( NOUT, FMT = 9997 ) ( NBVAL(I), I = 11, NNB )
438 WRITE( NOUT, FMT = 9996 )
439 $ 'nrhs ', ( NRVAL(I), I = 1, MIN(NNR, 10) )
440.GT. IF( NNR10 )
441 $ WRITE( NOUT, FMT = 9997 ) ( NRVAL(I), I = 11, NNR )
442 WRITE( NOUT, FMT = 9996 )
443 $ 'nbrhs', ( NBRVAL(I), I = 1, MIN(NNBR, 10) )
444.GT. IF( NNBR10 )
445 $ WRITE( NOUT, FMT = 9997 ) ( NBRVAL(I), I = 11, NNBR )
446 WRITE( NOUT, FMT = 9996 )
447 $ 'p ', ( PVAL(I), I = 1, MIN(NGRIDS, 10) )
448.GT. IF( NGRIDS10 )
449 $ WRITE( NOUT, FMT = 9997) ( PVAL(I), I = 11, NGRIDS )
450 WRITE( NOUT, FMT = 9996 )
451 $ 'q ', ( QVAL(I), I = 1, MIN(NGRIDS, 10) )
452.GT. IF( NGRIDS10 )
453 $ WRITE( NOUT, FMT = 9997 ) ( QVAL(I), I = 11, NGRIDS )
454 WRITE( NOUT, FMT = * )
455 WRITE( NOUT, FMT = 9995 ) EPS
456 WRITE( NOUT, FMT = 9998 ) THRESH
457*
458 ELSE
459*
460* If in pvm, must participate setting up virtual machine
461*
462.LT. IF( NPROCS1 )
463 $ CALL BLACS_SETUP( IAM, NPROCS )
464*
465* Temporarily define blacs grid to include all processes so
466* all processes have needed startup information
467*
468 CALL BLACS_GET( -1, 0, ICTXT )
469 CALL BLACS_GRIDINIT( ICTXT, 'row-major', 1, NPROCS )
470*
471* Compute machine epsilon
472*
473 EPS = PDLAMCH( ICTXT, 'eps' )
474*
475 CALL SGEBR2D( ICTXT, 'all', ' ', 1, 1, THRESH, 1, 0, 0 )
476 CALL IGEBR2D( ICTXT, 'all', ' ', 1, 1, I, 1, 0, 0 )
477 CALL IGEBR2D( ICTXT, 'all', ' ', I, 1, WORK, I, 0, 0 )
478 I = 1
479 NMAT = WORK( I )
480 I = I+1
481 NBW = WORK( I )
482 I = I+1
483 NNB = WORK( I )
484 I = I+1
485 NNR = WORK( I )
486 I = I+1
487 NNBR = WORK( I )
488 I = I+1
489 NGRIDS = WORK( I )
490 I = I+1
491.EQ. IF( WORK( I ) 1 ) THEN
492 UPLO = 'l'
493 ELSE
494 UPLO = 'u'
495 END IF
496 I = I+1
497*
498 I = NMAT + NBW + NNB + NNR + NNBR + 2*NGRIDS
499*
500 CALL IGEBR2D( ICTXT, 'all', ' ', 1, I, WORK, 1, 0, 0 )
501 I = 1
502 CALL ICOPY( NMAT, WORK( I ), 1, NVAL, 1 )
503 I = I + NMAT
504 CALL ICOPY( NBW, WORK( I ), 1, BWVAL, 1 )
505 I = I + NBW
506 CALL ICOPY( NNB, WORK( I ), 1, NBVAL, 1 )
507 I = I + NNB
508 CALL ICOPY( NNR, WORK( I ), 1, NRVAL, 1 )
509 I = I + NNR
510 CALL ICOPY( NNBR, WORK( I ), 1, NBRVAL, 1 )
511 I = I + NNBR
512 CALL ICOPY( NGRIDS, WORK( I ), 1, PVAL, 1 )
513 I = I + NGRIDS
514 CALL ICOPY( NGRIDS, WORK( I ), 1, QVAL, 1 )
515*
516 END IF
517*
518 CALL BLACS_GRIDEXIT( ICTXT )
519*
520 RETURN
521*
522 20 WRITE( NOUT, FMT = 9993 )
523 CLOSE( NIN )
524.NE..AND..NE. IF( NOUT6 NOUT0 )
525 $ CLOSE( NOUT )
526*
527 CALL BLACS_ABORT( ICTXT, 1 )
528 STOP
529*
530 9999 FORMAT( A )
531 9998 FORMAT( 'routines pass computational tests if scaled residual ',
532 $ 'is less than ', G12.5 )
533 9997 FORMAT( ' ', 10I6 )
534 9996 FORMAT( 2X, A5, ': ', 10I6 )
535 9995 FORMAT( 'relative machine precision(eps) is taken to be ',
536 $ E18.6 )
537 9994 FORMAT( ' number of values of ',5A, ' is less than 1 or greater ',
538 $ 'than ', I2 )
539 9993 FORMAT( ' illegal input in file ',40A,'. aborting run.' )
540*
541* End of PZPTINFO
542*
543 END
the
end diagonal values have been computed in the(sparse) matrix id.SOL
icopy
subroutine icopy(n, sx, incx, sy, incy)
ICOPY
Definition icopy.f:75
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
sgebs2d
subroutine sgebs2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1072
blacs_gridinit
subroutine blacs_gridinit(cntxt, c, nprow, npcol)
Definition mpi.f:745
sgebr2d
subroutine sgebr2d(contxt, scope, top, m, n, a, lda)
Definition mpi.f:1113
blacs_gridexit
subroutine blacs_gridexit(cntxt)
Definition mpi.f:762
for
for(i8=*sizetab-1;i8 >=0;i8--)
Definition mumps_common.c:91
split
void split(mapping_t *, PORD_INT, PORD_INT, PORD_INT, PORD_INT *, PORD_INT *, FLOAT *, PORD_INT)
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